home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / compiler / ir1tran.lisp < prev    next >
Encoding:
Text File  |  1992-05-21  |  124.1 KB  |  3,438 lines

  1. ;;; -*- Package: C; Log: C.Log -*-
  2. ;;;
  3. ;;; **********************************************************************
  4. ;;; This code was written as part of the CMU Common Lisp project at
  5. ;;; Carnegie Mellon University, and has been placed in the public domain.
  6. ;;; If you want to use this code or any part of CMU Common Lisp, please contact
  7. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
  8. ;;;
  9. (ext:file-comment
  10.   "$Header: ir1tran.lisp,v 1.66.1.2 92/05/21 18:04:40 ram Exp $")
  11. ;;;
  12. ;;; **********************************************************************
  13. ;;;
  14. ;;;    This file contains code which does the translation from Lisp code to the
  15. ;;; first intermediate representation (IR1).
  16. ;;;
  17. ;;; Written by Rob MacLachlan
  18. ;;;
  19. (in-package 'c)
  20.  
  21. (export '(*compile-time-define-macros* *converting-for-interpreter*
  22.       *suppress-values-declaration*))
  23.  
  24. (in-package "EXT")
  25. (export '(truly-the maybe-inline *derive-function-types*))
  26.  
  27. (in-package "LISP")
  28. (export '(ignorable symbol-macrolet))
  29.  
  30. (in-package 'c)
  31.  
  32.  
  33. (proclaim '(special *compiler-error-bailout*))
  34.  
  35.  
  36. ;;; The lexical environment we are currently converting in.  See the LEXENV
  37. ;;; structure.
  38. ;;;
  39. (defvar *lexical-environment*)
  40. (proclaim '(type lexenv *lexical-environment*))
  41.  
  42. ;;; That variable is used to control the context-sensitive declarations
  43. ;;; mechanism (see WITH-COMPILATION-UNIT).  Each entry is a function which is
  44. ;;; called with the function name and parent form name.  If it returns non-nil,
  45. ;;; then that is a list of DECLARE forms which should be inserted at the head
  46. ;;; of the body.
  47. ;;;
  48. (defvar *context-declarations* ())
  49. (declaim (list *context-declarations*))
  50.  
  51. ;;; *free-variables* translates from the names of variables referenced globally
  52. ;;; to the Leaf structures for them.  *free-functions* is like
  53. ;;; *free-variables*, only it deals with function names.
  54. ;;;
  55. ;;; We must preserve the property that a proclamation for a global thing
  56. ;;; only affects the code after it.  This takes some work, since a proclamation
  57. ;;; may appear in the middle of a block being compiled.  If there are
  58. ;;; references before the proclaim, then we copy the current entry before
  59. ;;; modifying it.  Code converted before the proclaim sees the old Leaf, while
  60. ;;; code after it sees the new Leaf.
  61. ;;;
  62. (defvar *free-variables*)
  63. (defvar *free-functions*)
  64. (proclaim '(hash-table *free-variables* *free-functions*))
  65.  
  66. ;;; We use the same Constant structure to represent all equal anonymous
  67. ;;; constants.  This hashtable translates from constants to the Leafs that
  68. ;;; represent them.
  69. ;;;
  70. (defvar *constants*)
  71. (proclaim '(hash-table *constants*))
  72.  
  73. ;;; *source-paths* is a hashtable from source code forms to the path taken
  74. ;;; through the source to reach the form.  This provides a way to keep track of
  75. ;;; the location of original source forms, even when macroexpansions and other
  76. ;;; arbitary permutations of the code happen.  This table is initialized by
  77. ;;; calling Find-Source-Paths on the original source.
  78. ;;;
  79. (proclaim '(hash-table *source-paths*))
  80. (defvar *source-paths*)
  81.  
  82. ;;; *Current-Component* is the Component structure which we link blocks into as
  83. ;;; we generate them.  This just serves to glue the emitted blocks together
  84. ;;; until local call analysis and flow graph canonicalization figure out what
  85. ;;; is really going on.  We need to keep track of all the blocks generated so
  86. ;;; that we can delete them if they turn out to be unreachable.
  87. ;;;
  88. (proclaim '(type (or component null) *current-component*))
  89. (defvar *current-component*)
  90.  
  91. ;;; *Current-Path* is the source path of the form we are currently translating.
  92. ;;; See NODE-SOURCE-PATH in the NODE structure.
  93. ;;;
  94. (proclaim '(list *current-path*))
  95. (defvar *current-path* nil)
  96.  
  97. ;;; *Converting-For-Interpreter* is true when we are creating IR1 to be
  98. ;;; interpreted rather than compiled.  This inhibits source tranformations and
  99. ;;; stuff.
  100. ;;;
  101. (defvar *converting-for-interpreter* nil)
  102.  
  103. ;;; *Compile-Time-Define-Macros* is true when we want DEFMACRO definitions to
  104. ;;; be installed in the compilation environment as interpreted functions.  We
  105. ;;; set this to false when compiling some parts of the system.
  106. ;;;
  107. (defvar *compile-time-define-macros* t)
  108.  
  109.  
  110. ;;; IR1-Error-Bailout  --  Internal
  111. ;;;
  112. ;;;    Bind *compiler-error-bailout* to a function throws out of the body and
  113. ;;; converts a proxy form instead.
  114. ;;;
  115. (defmacro ir1-error-bailout
  116.       ((start cont form
  117.         &optional
  118.         (proxy '`(error "Execution of a form compiled with errors:~% ~S"
  119.                 ',*bailout-form*)))
  120.        &body body)
  121.   `(catch 'ir1-error-abort 
  122.      (let ((*bailout-start* ,start)
  123.        (*bailout-cont* ,cont)
  124.        (*bailout-form* ,form)
  125.        (*compiler-error-bailout*
  126.         #'(lambda ()
  127.         (declare (special *bailout-start* *bailout-cont*
  128.                   *bailout-form*))
  129.         (ir1-convert *bailout-start* *bailout-cont* ,proxy)
  130.         (throw 'ir1-error-abort nil))))
  131.        (declare (special *bailout-start* *bailout-cont* *bailout-form*))
  132.        ,@body
  133.        nil)))
  134.  
  135.             
  136. ;;; IR1-Convert  --  Interface
  137. ;;;
  138. ;;;    Translate Form into IR1.  The code is inserted as the Next of the
  139. ;;; continuation Start.  Cont is the continuation which receives the value of
  140. ;;; the Form to be translated.  The translators call this function recursively
  141. ;;; to translate their subnodes.
  142. ;;;
  143. ;;;    As a special hack to make life easier in the compiler, a Leaf
  144. ;;; IR1-converts into a reference to that leaf structure.  This allows the
  145. ;;; creation using backquote of forms that contain leaf references, without
  146. ;;; having to introduce dummy names into the namespace.
  147. ;;;
  148. (proclaim '(function ir1-convert (continuation continuation t) void))
  149. (defun ir1-convert (start cont form)
  150.   (ir1-error-bailout (start cont form)
  151.     (let ((*current-path* (or (gethash form *source-paths*)
  152.                   (cons form *current-path*))))
  153.       (if (atom form)
  154.       (cond ((and (symbolp form) (not (keywordp form)))
  155.          (ir1-convert-variable start cont form))
  156.         ((leaf-p form)
  157.          (reference-leaf start cont form nil))
  158.         (t
  159.          (reference-constant start cont form)))
  160.       (let ((fun (car form)))
  161.         (cond
  162.          ((symbolp fun)
  163.           (let ((lexical-def (lexenv-find fun functions)))
  164.         (cond
  165.          ((not lexical-def)
  166.           (ir1-convert-global-functoid start cont form))
  167.          ((leaf-p lexical-def)
  168.           (ir1-convert-local-function start cont form lexical-def))
  169.          (t
  170.           (assert (and (consp lexical-def)
  171.                    (eq (car lexical-def) 'macro)))
  172.           (ir1-convert-macro start cont (cdr lexical-def) form)))))
  173.          ((or (atom fun) (not (eq (car fun) 'lambda)))
  174.           (compiler-error "Illegal function call."))
  175.          (t
  176.           (ir1-convert-combination start cont form
  177.                        (ir1-convert-lambda fun)))))))))
  178.  
  179.  
  180. ;;; IR1-Convert-Global-Functoid  --  Internal
  181. ;;;
  182. ;;;    Convert anything that looks like a special-form, global function or
  183. ;;; macro call.
  184. ;;;
  185. (defun ir1-convert-global-functoid (start cont form)
  186.   (declare (type continuation start cont)
  187.        (list form))
  188.   (unless *converting-for-interpreter*
  189.     (multiple-value-bind
  190.     (new-form expanded)
  191.     (handler-case
  192.         (compiler-macroexpand-1 form *lexical-environment*)
  193.       (error (cond)
  194.         (compiler-warning "Compiler-Macroexpansion failed:~%~A" cond)
  195.         (values nil nil)))
  196.       (when expanded
  197.     (return-from ir1-convert-global-functoid
  198.              (ir1-convert start cont new-form)))))
  199.   (let* ((fun (first form))
  200.      (translator (info function ir1-convert fun)))
  201.     (if translator
  202.     (funcall translator start cont form)
  203.     (ecase (info function kind fun)
  204.       (:macro
  205.        (let ((expander (info function macro-function fun)))
  206.          (assert expander (expander)
  207.              "No macro-function for global macro ~S." fun)
  208.          (ir1-convert-macro start cont expander form)))
  209.       ((nil :function)
  210.        (ir1-convert-global-function start cont form)))))
  211.   (undefined-value))
  212.  
  213.  
  214. ;;; IR1-Convert-Macro  --  Internal
  215. ;;;
  216. ;;;    Trap errors during the macroexpansion.
  217. ;;;
  218. (defun ir1-convert-macro (start cont fun form)
  219.   (declare (type continuation start cont))
  220.   (ir1-convert start cont
  221.            (handler-case (invoke-macroexpand-hook fun form
  222.                               *lexical-environment*)
  223.          (error (condition)
  224.            (compiler-error "(during macroexpansion)~%~A"
  225.                    condition)))))
  226.  
  227.  
  228. ;;; Leaf-Inlinep  --  Internal
  229. ;;;
  230. ;;;    Return the current Inlinep value for references to Leaf.
  231. ;;;
  232. (defun leaf-inlinep (leaf)
  233.   (declare (type leaf leaf))
  234.   (multiple-value-bind (val found)
  235.                (lexenv-find leaf inlines)
  236.     (if found
  237.     val
  238.     (etypecase leaf
  239.       (functional nil)
  240.       (global-var
  241.        (assert (eq (global-var-kind leaf) :global-function))
  242.        (info function inlinep (leaf-name leaf)))))))
  243.  
  244.  
  245. ;;; IR1-Convert-Local-Function  --  Internal
  246. ;;;
  247. ;;;    Convert a call to a local function.  If speed is important, we a have an
  248. ;;; inline expansion and the function is :inline, then convert the inline
  249. ;;; expansion instead of a reference to the existing function.
  250. ;;;
  251. (proclaim '(function ir1-convert-local-function 
  252.              (continuation continuation t leaf) void))
  253. (defun ir1-convert-local-function (start cont form var)
  254.   (let ((inlinep (leaf-inlinep var))
  255.     (expansion (if (functional-p var)
  256.                (functional-inline-expansion var))))
  257.     (cond ((and expansion (eq inlinep :inline)
  258.          (policy nil (>= speed space) (>= speed cspeed)))
  259.        (setf (leaf-ever-used var) t)
  260.        (ir1-convert-combination start cont form 
  261.                     (let ((*lexical-environment*
  262.                        (functional-lexenv var)))
  263.                       (ir1-convert-lambda expansion))
  264.                     :inline))
  265.       (t
  266.        (ir1-convert-combination start cont form var inlinep)))))
  267.  
  268.  
  269. ;;; IR1-Convert-Combination  --  Internal
  270. ;;;
  271. ;;;    Convert a function call where the function is a Leaf.  Inlinep is the
  272. ;;; value of Inlinep for the Ref.  We return the Combination node so that we
  273. ;;; can poke at it if we want to.
  274. ;;;
  275. (proclaim '(function ir1-convert-combination
  276.              (continuation continuation list leaf &optional inlinep)
  277.              combination))
  278. (defun ir1-convert-combination (start cont form fun &optional (inlinep nil))
  279.   (let ((fun-cont (make-continuation)))
  280.     (reference-leaf start fun-cont fun inlinep)
  281.     (ir1-convert-combination-args fun-cont cont (cdr form))))
  282.  
  283.  
  284. ;;; IR1-Convert-Combination-Args  --  Internal
  285. ;;;
  286. ;;;    Convert the arguments to a call and make the Combination node.  Fun-Cont
  287. ;;; is the continuation which yields the function to call.  Form is the source
  288. ;;; for the call.  Args is the list of arguments for the call, which defaults
  289. ;;; to the cdr of source.  We return the Combination node.
  290. ;;;
  291. (defun ir1-convert-combination-args (fun-cont cont args)
  292.   (declare (type continuation fun-cont cont) (list args))
  293.   (let ((node (make-combination fun-cont)))
  294.     (setf (continuation-dest fun-cont) node)
  295.     (assert-continuation-type fun-cont
  296.                   (specifier-type '(or function symbol)))
  297.     (collect ((arg-conts))
  298.       (let ((this-start fun-cont))
  299.     (dolist (arg args)
  300.       (let ((this-cont (make-continuation node)))
  301.         (ir1-convert this-start this-cont arg)
  302.         (setq this-start this-cont)
  303.         (arg-conts this-cont)))
  304.     (prev-link node this-start)
  305.     (use-continuation node cont)
  306.     (setf (combination-args node) (arg-conts))))
  307.     node))
  308.  
  309.  
  310. ;;; IR1-Convert-Progn-Body  --  Internal
  311. ;;;
  312. ;;;    Convert a bunch of forms, discarding all the values except the last.
  313. ;;; If there aren't any forms, then translate a NIL.
  314. ;;;
  315. (proclaim '(function ir1-convert-progn-body (continuation continuation list) void))
  316. (defun ir1-convert-progn-body (start cont body)
  317.   (if (endp body)
  318.       (reference-constant start cont nil)
  319.       (let ((this-start start)
  320.         (forms body))
  321.     (loop
  322.       (let ((form (car forms)))
  323.         (when (endp (cdr forms))
  324.           (ir1-convert this-start cont form)
  325.           (return))
  326.         (let ((this-cont (make-continuation)))
  327.           (ir1-convert this-start this-cont form)
  328.           (setq this-start this-cont  forms (cdr forms))))))))
  329.  
  330.  
  331. ;;; IR1-Convert-Global-Function  --  Internal
  332. ;;;
  333. ;;;    Convert a call to a global function.  If the function has a
  334. ;;; source-transform and inline expansion is enabled then we convert its
  335. ;;; expansion.  If the source transform returns a non-null second value, then
  336. ;;; we act as though there was no source transformation, and directly convert
  337. ;;; the call.
  338. ;;;
  339. (proclaim '(function ir1-convert-global-function (continuation continuation list) void))
  340. (defun ir1-convert-global-function (start cont form)
  341.   (let ((name (car form)))
  342.     (multiple-value-bind (var inlinep)
  343.              (find-free-function name "in a reasonable place")
  344.       (cond
  345.        ((eq inlinep :notinline)
  346.     (ir1-convert-combination start cont form var inlinep))
  347.        (*converting-for-interpreter*
  348.     (ir1-convert-ok-combination-fer-sher start cont form var))
  349.        (t
  350.     (let ((transform (info function source-transform name))
  351.           (expansion (info function inline-expansion name)))
  352.       (cond
  353.        (transform
  354.         (multiple-value-bind (result pass)
  355.                  (funcall transform form)
  356.           (if pass
  357.           (ir1-convert-ok-combination start cont form var)
  358.           (ir1-convert start cont result))))
  359.        (expansion
  360.         (ir1-convert-global-inline start cont form var inlinep expansion))
  361.        (t
  362.         (when (and (eq inlinep :inline) (policy nil (> speed brevity))
  363.                (not (info function info name)))
  364.           (compiler-note "~S is declared inline, but has no expansion."
  365.                  name))
  366.         (ir1-convert-ok-combination start cont form var)))))))))
  367.  
  368.  
  369. ;;; IR1-Convert-Ok-Combination  --  Internal
  370. ;;;
  371. ;;;    Convert a global function call that we are allowed to early bind.  We
  372. ;;; find any Function-Info for Var.  Although Var is not necessarily a
  373. ;;; Global-Var, it is in the global namespace, so we can assume that we know
  374. ;;; about it if we recognize the name.
  375. ;;;
  376. ;;;    If the function has the Predicate attribute, and the CONT's DEST isn't
  377. ;;; an IF, then we convert (IF <form> T NIL), ensuring that a predicate always
  378. ;;; appears in a conditional context.
  379. ;;;
  380. ;;;    If the function isn't a predicate, then we call
  381. ;;; IR1-Convert-OK-Combination-Fer-Sher.
  382. ;;;
  383. (defun ir1-convert-ok-combination (start cont form var)
  384.   (declare (type continuation start cont) (list form) (type leaf var))
  385.   (let ((info (info function info (leaf-name var))))
  386.     (if (and info
  387.          (ir1-attributep (function-info-attributes info) predicate)
  388.          (not (if-p (continuation-dest cont))))
  389.     (ir1-convert start cont `(if ,form t nil))
  390.     (ir1-convert-ok-combination-fer-sher start cont form var))))
  391.  
  392.  
  393. ;;; IR1-Convert-OK-Combination-Fer-Sher  --  Internal
  394. ;;;
  395. ;;;    Actually really convert a global function call that we are allowed to
  396. ;;; early-bind.
  397. ;;;
  398. ;;; If we know the function type of the function, then we check the call for
  399. ;;; syntactic legality with respect to the declared function type.  If it is
  400. ;;; impossible to determine whether the call is correct due to non-constant
  401. ;;; keywords, then we give up, marking the Ref as :Notinline to inhibit further
  402. ;;; error messages.  We return true when the call is legal.
  403. ;;;
  404. ;;; If the call is legal, we also propagate type assertions from the function
  405. ;;; type to the arg and result continuations.  We do this now so that IR1
  406. ;;; optimize doesn't have to redundantly do the check later so that it can do
  407. ;;; the type propagation.
  408. ;;;
  409. ;;; If the function is unknown, then we note the name and error context so that
  410. ;;; we can give a warning if the function is never defined.
  411. ;;;
  412. (defun ir1-convert-ok-combination-fer-sher (start cont form var)
  413.   (declare (type continuation start cont) (list form) (type leaf var))
  414.   (let ((fun-cont (make-continuation)))
  415.     (reference-leaf start fun-cont var nil)
  416.     (let ((type (leaf-type var))
  417.       (node (ir1-convert-combination-args fun-cont cont (cdr form))))
  418.       (cond
  419.        ((eq (leaf-where-from var) :assumed)
  420.     (let ((name (leaf-name var)))
  421.       (when (and (eq (info function where-from name) :assumed)
  422.              (eq (info function kind name) :function))
  423.         (setf (info function assumed-type name)
  424.           (note-function-use node
  425.                      (info function assumed-type name)))))
  426.     nil)
  427.        ((not (function-type-p type)) nil)
  428.        ((valid-function-use node type
  429.                 :argument-test #'always-subtypep
  430.                 :result-test #'always-subtypep
  431.                 :error-function #'compiler-warning
  432.                 :warning-function #'compiler-note)
  433.     (recognize-known-call node)
  434.     (assert-call-type node type)
  435.     (unless *converting-for-interpreter*
  436.       (maybe-terminate-block node t))
  437.     (setf (continuation-%derived-type fun-cont) type)
  438.     (setf (continuation-reoptimize fun-cont) nil)
  439.     (setf (continuation-%type-check fun-cont) nil)
  440.     t)
  441.        (t
  442.     (setf (ref-inlinep (continuation-use fun-cont)) :notinline)
  443.     nil)))))
  444.  
  445.  
  446. ;;; In-Null-Environment  --  Internal
  447. ;;;
  448. ;;;    Return true if the lexical environment is null.  If Macros-OK is true,
  449. ;;; then it is ok for there there to be local macros and other compile-time
  450. ;;; stuff in the environment.
  451. ;;;
  452. (defun in-null-environment (&optional macros-ok)
  453.   (let* ((env *lexical-environment*)
  454.      (functions (lexenv-functions env)))
  455.     (and (if macros-ok
  456.          (every #'(lambda (x)
  457.             (let ((val (cdr x)))
  458.               (and (consp val)
  459.                    (eq (car val) 'macro))))
  460.             functions)
  461.          (null functions))
  462.      (null (lexenv-blocks env))
  463.      (null (lexenv-variables env))
  464.      (null (lexenv-tags env)))))
  465.  
  466.  
  467. ;;; IR1-Convert-Global-Lambda  --  Interface
  468. ;;;
  469. ;;;    Like IR1-Convert-Lambda except that we null out the environment
  470. ;;; variables around the conversion.  This is used when we are converting an
  471. ;;; inline expansion.  We pass through the cookie, since that seems more
  472. ;;; useful.
  473. ;;;
  474. (defun ir1-convert-global-lambda (fun)
  475.   (let ((*lexical-environment*
  476.      (make-lexenv
  477.       :default (make-null-environment)
  478.       :cookie (lexenv-cookie *lexical-environment*)
  479.       :interface-cookie (lexenv-interface-cookie *lexical-environment*))))
  480.     (ir1-convert-lambda fun)))
  481.  
  482.  
  483. ;;; IR1-Convert-Global-Inline  --  Internal
  484. ;;;
  485. ;;;    Convert a call to a global function which has an inline expansion.  We
  486. ;;; make a number of speed v.s. space policy decisions using information from
  487. ;;; our extended inline declaration.  We don't do anything unless either the
  488. ;;; function is :INLINE or space is totally unimportant.  If :INLINE, we do
  489. ;;; normal copy-per-call inlining, otherwise we share a single copy across all
  490. ;;; calls.
  491. ;;;
  492. ;;;   We allow inlining of recursive functions through a similar hack to that
  493. ;;; used for LABELS.  Recursive inline expansion is prevented, instead we do a
  494. ;;; recursive local call.
  495. ;;;
  496. (proclaim '(function ir1-convert-global-inline
  497.              (continuation continuation t leaf inlinep list)
  498.              void))
  499. (defun ir1-convert-global-inline (start cont form var inlinep expansion)
  500.   (if (and (case inlinep
  501.          (:notinline nil)
  502.          (:inline t)
  503.          (t (policy nil (zerop space))))
  504.        (not (functional-p var)))
  505.       (let* ((name (leaf-name var))
  506.          (dummy (make-functional :name name)))
  507.     (setf (gethash name *free-functions*) dummy)
  508.     (let ((fun (ir1-convert-global-lambda expansion)))
  509.       (setf (leaf-name fun) name)
  510.       (substitute-leaf-if 
  511.        #'(lambda (x)
  512.            (not (eq (ref-inlinep x) :notinline)))
  513.        fun dummy)
  514.       (substitute-leaf var dummy)
  515.       (setf (gethash name *free-functions*)
  516.         (if (eq inlinep :inline)
  517.             var
  518.             fun))
  519.       (let ((res (ir1-convert-combination start cont form fun))
  520.         (type (leaf-type var))
  521.         (where-from (leaf-where-from var)))
  522.         (when (function-type-p type)
  523.           (when (eq where-from :declared)
  524.         (assert-definition-type fun type
  525.                     :warning-function #'compiler-note
  526.                     :where "previous declaration"))
  527.           (assert-call-type res type)))))
  528.       (ir1-convert-ok-combination start cont form var)))
  529.  
  530.  
  531. ;;;; Lambda hackery:  
  532.  
  533. ;;; Varify-Lambda-Arg  --  Internal
  534. ;;;
  535. ;;;    Verify that a thing is a legal name for a variable and return a Var
  536. ;;; structure for it, filling in info if it is globally special.  If it is
  537. ;;; losing, we punt with a Compiler-Error.  Names-So-Far is an alist of names
  538. ;;; which have previously been bound.  If the name is in this list, then we
  539. ;;; error out.
  540. ;;;
  541. (proclaim '(function varify-lambda-arg (t list) lambda-var))
  542. (defun varify-lambda-arg (name names-so-far)
  543.   (unless (symbolp name)
  544.     (compiler-error "Lambda-variable is not a symbol: ~S." name))
  545.   (when (member name names-so-far)
  546.     (compiler-error "Repeated variable in lambda-list: ~S." name))
  547.   (let ((kind (info variable kind name)))
  548.     (when (or (keywordp name) (eq kind :constant))
  549.       (compiler-error "Name of lambda-variable is a constant: ~S." name))
  550.     (if (eq kind :special)
  551.     (let ((specvar (find-free-variable name)))
  552.       (make-lambda-var :name name
  553.                :type (leaf-type specvar)
  554.                :where-from (leaf-where-from specvar)
  555.                :specvar specvar))
  556.     (make-lambda-var :name name))))
  557.  
  558.  
  559. ;;; Make-Keyword  --  Internal
  560. ;;;
  561. ;;;    Make the keyword for a keyword arg, checking that the keyword isn't
  562. ;;; already used by one of the Vars.  We also check that the keyword isn't the
  563. ;;; magical :allow-other-keys.
  564. ;;;
  565. (proclaim '(function make-keyword (symbol list) keyword))
  566. (defun make-keyword (symbol vars)
  567.   (let ((key (if (keywordp symbol) symbol
  568.          (intern (symbol-name symbol) "KEYWORD"))))
  569.     (when (eq key :allow-other-keys)
  570.       (compiler-error "You can't have a keyword arg called :allow-other-keys."))
  571.     (dolist (var vars)
  572.       (let ((info (lambda-var-arg-info var)))
  573.     (when (and info
  574.            (eq (arg-info-kind info) :keyword)
  575.            (eq (arg-info-keyword info) key))
  576.       (compiler-error "Multiple uses of keyword ~S in lambda-list." key))))
  577.     key))
  578.  
  579.  
  580. ;;; Find-Lambda-Vars  --  Internal
  581. ;;;
  582. ;;;    Parse a lambda-list into a list of Var structures, stripping off any aux
  583. ;;; bindings.  Each arg name is checked for legality, and duplicate names are
  584. ;;; checked for.  If an arg is globally special, the var is marked as :special
  585. ;;; instead of :lexical.  Keyword, optional and rest args are annotated with an
  586. ;;; arg-info structure which contains the extra information.  If we hit
  587. ;;; something losing, we bug out with Compiler-Error.  These values are
  588. ;;; returned:
  589. ;;;  1] A list of the var structures for each top-level argument.
  590. ;;;  2] A flag indicating whether &key was specified.
  591. ;;;  3] A flag indicating whether other keyword args are allowed.
  592. ;;;  4] A list of the &aux variables.
  593. ;;;  5] A list of the &aux values.
  594. ;;;
  595. (proclaim '(function find-lambda-vars (list)
  596.              (values list boolean boolean list list)))
  597. (defun find-lambda-vars (list)
  598.   (multiple-value-bind (required optional restp rest keyp keys allowp aux)
  599.                (parse-lambda-list list)
  600.     (collect ((vars)
  601.           (names-so-far)
  602.           (aux-vars)
  603.           (aux-vals))
  604.       ;;
  605.       ;; Parse-Default deals with defaults and supplied-p args for optionals
  606.       ;; and keywords args.
  607.       (flet ((parse-default (spec info)
  608.            (when (consp (cdr spec))
  609.          (setf (arg-info-default info) (second spec))
  610.          (when (consp (cddr spec))
  611.            (let* ((supplied-p (third spec))
  612.               (supplied-var (varify-lambda-arg supplied-p (names-so-far))))
  613.              (setf (arg-info-supplied-p info) supplied-var)
  614.              (names-so-far supplied-p)
  615.              (when (> (length spec) 3)
  616.                (compiler-error "Arg specifier is too long: ~S." spec)))))))
  617.     
  618.     (dolist (name required)
  619.       (let ((var (varify-lambda-arg name (names-so-far))))
  620.         (vars var)
  621.         (names-so-far name)))
  622.     
  623.     (dolist (spec optional)
  624.       (if (atom spec)
  625.           (let ((var (varify-lambda-arg spec (names-so-far))))
  626.         (setf (lambda-var-arg-info var) (make-arg-info :kind :optional))
  627.         (vars var)
  628.         (names-so-far spec))
  629.           (let* ((name (first spec))
  630.              (var (varify-lambda-arg name (names-so-far)))
  631.              (info (make-arg-info :kind :optional)))
  632.         (setf (lambda-var-arg-info var) info)
  633.         (vars var)
  634.         (names-so-far name)
  635.         (parse-default spec info))))
  636.     
  637.     (when restp
  638.       (let ((var (varify-lambda-arg rest (names-so-far))))
  639.         (setf (lambda-var-arg-info var) (make-arg-info :kind :rest))
  640.         (vars var)
  641.         (names-so-far rest)))
  642.     
  643.     (dolist (spec keys)
  644.       (cond
  645.        ((atom spec)
  646.         (let ((var (varify-lambda-arg spec (names-so-far))))
  647.           (setf (lambda-var-arg-info var)
  648.             (make-arg-info :kind :keyword
  649.                    :keyword (make-keyword spec (vars))))
  650.           (vars var)
  651.           (names-so-far spec)))
  652.        ((atom (first spec))
  653.         (let* ((name (first spec))
  654.            (var (varify-lambda-arg name (names-so-far)))
  655.            (info (make-arg-info :kind :keyword
  656.                     :keyword (make-keyword name (vars)))))
  657.           (setf (lambda-var-arg-info var) info)
  658.           (vars var)
  659.           (names-so-far name)
  660.           (parse-default spec info)))
  661.        (t
  662.         (let ((head (first spec)))
  663.           (unless (= (length head) 2)
  664.         (error "Malformed keyword arg specifier: ~S." spec))
  665.           (let* ((name (second head))
  666.              (var (varify-lambda-arg name (names-so-far)))
  667.              (info (make-arg-info :kind :keyword
  668.                       :keyword (make-keyword (first head)
  669.                                  (vars)))))
  670.         (setf (lambda-var-arg-info var) info)
  671.         (vars var)
  672.         (names-so-far name)
  673.         (parse-default spec info))))))
  674.     
  675.     (dolist (spec aux)
  676.       (cond ((atom spec)
  677.          (let ((var (varify-lambda-arg spec nil)))
  678.            (aux-vars var)
  679.            (aux-vals nil)
  680.            (names-so-far spec)))
  681.         (t
  682.          (unless (<= 1 (length spec) 2)
  683.            (compiler-error "Malformed &aux binding specifier: ~S."
  684.                    spec))
  685.          (let* ((name (first spec))
  686.             (var (varify-lambda-arg name nil)))
  687.            (aux-vars var)
  688.            (aux-vals (second spec))
  689.            (names-so-far name)))))
  690.       
  691.     (values (vars) keyp allowp (aux-vars) (aux-vals))))))
  692.  
  693.  
  694. ;;; Find-In-Bindings  --  Internal
  695. ;;;
  696. ;;;    Given a list of Lambda-Var structures and a variable name, return the
  697. ;;; structure for that name, or NIL if it isn't found.  We return the *last*
  698. ;;; variable with that name, since let* bindings may be duplicated, and
  699. ;;; declarations always apply to the last.
  700. ;;;
  701. (proclaim '(function find-in-bindings (list symbol) (or lambda-var list)))
  702. (defun find-in-bindings (vars name)
  703.   (let ((found nil))
  704.     (dolist (var vars)
  705.       (cond ((leaf-p var)
  706.          (when (eq (leaf-name var) name)
  707.            (setq found var))
  708.          (let ((info (lambda-var-arg-info var)))
  709.            (when info
  710.          (let ((supplied-p (arg-info-supplied-p info)))
  711.            (when (and supplied-p
  712.                   (eq (leaf-name supplied-p) name))
  713.              (setq found supplied-p))))))
  714.         ((and (consp var) (eq (car var) name))
  715.          (setf found (cdr var)))))
  716.     found))
  717.  
  718.  
  719. ;;; Find-Lexically-Apparent-Function  --  Internal
  720. ;;;
  721. ;;;    Return the Leaf structure for the lexically apparent function definition
  722. ;;; of Name.  The second value is the inlinep information which currently
  723. ;;; applies to the variable.
  724. ;;;
  725. (proclaim '(function find-lexically-apparent-function (t string)
  726.              (values leaf inlinep)))
  727. (defun find-lexically-apparent-function (name context)
  728.   (let ((var (lexenv-find name functions :test #'equal)))
  729.     (cond (var
  730.        (unless (leaf-p var)
  731.          (assert (and (consp var) (eq (car var) 'macro)))
  732.          (compiler-error "Found macro name ~S ~A." name context))
  733.        (values var (leaf-inlinep var)))
  734.       (t
  735.        (find-free-function name context)))))
  736.  
  737.  
  738. ;;; Process-Type-Declaration  --  Internal
  739. ;;;
  740. ;;;    Called by Process-Declarations to deal with a variable type declaration.
  741. ;;; If a lambda-var being bound, we intersect the type with the vars type,
  742. ;;; otherwise we add a type-restriction on the var.  If a symbol macro, we just
  743. ;;; wrap a THE around the expansion.
  744. ;;;
  745. (defun process-type-declaration (decl res vars)
  746.   (declare (list decl vars) (type lexenv res))
  747.   (let ((type (specifier-type (first decl))))
  748.     (collect ((restr nil cons)
  749.           (new-vars nil cons))
  750.       (dolist (var-name (rest decl))
  751.     (let* ((bound-var (find-in-bindings vars var-name))
  752.            (var (or bound-var
  753.             (lexenv-find var-name variables)
  754.             (find-free-variable var-name))))
  755.       (etypecase var
  756.         (leaf
  757.          (let* ((old-type (or (lexenv-find var type-restrictions)
  758.                   (leaf-type var)))
  759.             (int (if (or (function-type-p type)
  760.                  (function-type-p old-type))
  761.                  type
  762.                  (type-intersection old-type type))))
  763.            (cond ((eq int *empty-type*)
  764.               (unless (policy nil (= brevity 3))
  765.             (compiler-warning
  766.              "Conflicting type declarations ~S and ~S for ~S."
  767.              (type-specifier old-type) (type-specifier type)
  768.              var-name)))
  769.              (bound-var (setf (leaf-type bound-var) int))
  770.              (t
  771.               (restr (cons var int))))))
  772.         (cons
  773.          (assert (eq (car var) 'MACRO))
  774.          (new-vars `(,var-name . (MACRO . (the ,(first decl)
  775.                            ,(cdr var))))))
  776.         (heap-alien-info
  777.          (compiler-error "Can't declare type of Alien variable: ~S."
  778.                  var-name)))))
  779.  
  780.       (if (or (restr) (new-vars))
  781.       (make-lexenv :default res
  782.                :type-restrictions (restr)
  783.                :variables (new-vars))
  784.       res))))
  785.  
  786.  
  787. ;;; Process-Ftype-Declaration  --  Internal
  788. ;;;
  789. ;;;    Somewhat similar to Process-Type-Declaration, but handles declarations
  790. ;;; for function variables.  In addition to allowing declarations for functions
  791. ;;; being bound, we must also deal with declarations that constrain the type of
  792. ;;; lexically apparent functions.
  793. ;;;
  794. (defun process-ftype-declaration (spec res names fvars)
  795.   (declare (list spec names fvars) (type lexenv res))
  796.   (let ((type (specifier-type spec)))
  797.     (collect ((res nil cons))
  798.       (dolist (name names)
  799.     (let ((found (find name fvars :key #'leaf-name)))
  800.       (cond
  801.        (found
  802.         (setf (leaf-type found) type)
  803.         (assert-definition-type found type
  804.                     :warning-function #'compiler-note
  805.                     :where "FTYPE declaration"))
  806.        (t
  807.         (res (cons (find-lexically-apparent-function
  808.             name "in a function type declaration")
  809.                type))))))
  810.       (if (res)
  811.       (make-lexenv :default res  :type-restrictions (res))
  812.       res))))
  813.  
  814.  
  815. ;;; PROCESS-SPECIAL-DECLARATION  --  Internal
  816. ;;;
  817. ;;;    Process a special declaration, returning a new LEXENV.  A non-bound
  818. ;;; special declaration is instantiated by throwing a special variable into the
  819. ;;; variables.
  820. ;;;
  821. (defun process-special-declaration (spec res vars)
  822.   (declare (list spec vars) (type lexenv res))
  823.   (collect ((new-venv nil cons))
  824.     (dolist (name (cdr spec))
  825.       (let ((var (find-in-bindings vars name)))
  826.     (etypecase var
  827.       (cons
  828.        (assert (eq (car var) 'MACRO))
  829.        (compiler-error "Declaring symbol-macro ~S special." name))
  830.       (lambda-var
  831.        (when (lambda-var-ignorep var)
  832.          (compiler-warning
  833.           "Ignored variable ~S is being declared special."
  834.           name))
  835.        (setf (lambda-var-specvar var)
  836.          (specvar-for-binding name)))
  837.       (null
  838.        (unless (assoc name (new-venv))
  839.          (new-venv (cons name (specvar-for-binding name))))))))
  840.     (if (new-venv)
  841.     (make-lexenv :default res  :variables (new-venv))
  842.     res)))
  843.  
  844.  
  845. ;;; PROCESS-INLINE-DECLARATION  --  Internal
  846. ;;;
  847. ;;;    Parse an inline/notinline declaration, checking for conflicting
  848. ;;; declarations.
  849. ;;;
  850. (defun process-inline-declaration (spec res fvars)
  851.   (declare (list spec fvars) (type lexenv res))
  852.   (collect ((new-inlines nil cons))
  853.     (let ((sense (case (first spec)
  854.            (inline :inline)
  855.            (notinline :notinline)
  856.            (maybe-inline :maybe-inline))))
  857.       (dolist (name (rest spec))
  858.     (let* ((var (or (find name fvars :key #'leaf-name)
  859.             (find-lexically-apparent-function
  860.              name
  861.              "in an inline or notinline declaration")))
  862.            (found (cdr (assoc var (new-inlines)))))
  863.       (if found
  864.           (unless (eq found sense)
  865.         (compiler-warning
  866.          "Conflicts with previous inline/notinline declaration: ~S."
  867.          spec))
  868.           (new-inlines (cons var sense))))))
  869.     (make-lexenv :default res  :inlines (new-inlines))))
  870.  
  871.  
  872. ;;; FIND-IN-BINDINGS-OR-FBINDINGS  --  Internal
  873. ;;;
  874. ;;;    Like FIND-IN-BINDINGS, but looks for #'foo in the fvars.
  875. ;;;
  876. (defun find-in-bindings-or-fbindings (name vars fvars)
  877.   (declare (list vars fvars))
  878.   (if (consp name)
  879.       (destructuring-bind (wot fn-name) name
  880.     (unless (eq wot 'function)
  881.       (compiler-error "Unrecognizable function or variable name: ~S"
  882.               name))
  883.     (find fn-name fvars :key #'leaf-name))
  884.       (find-in-bindings vars name)))
  885.  
  886.  
  887. ;;; PROCESS-IGNORE-DECLARATION  --  Internal
  888. ;;;
  889. ;;;    Process an ignore/ignorable declaration, checking for variious losing
  890. ;;; conditions.
  891. ;;;
  892. (defun process-ignore-declaration (spec vars fvars)
  893.   (declare (list spec vars fvars))
  894.   (dolist (name (rest spec))
  895.     (let ((var (find-in-bindings-or-fbindings name vars fvars)))
  896.       (cond
  897.        ((not var)
  898.     (compiler-warning
  899.      "Ignore declaration for unknown variable ~S." name))
  900.        ((and (consp var) (consp (cdr var)) (eq (cadr var) 'macro))
  901.     ;; Just ignore the ignore decl.
  902.     )
  903.        ((functional-p var)
  904.     (setf (leaf-ever-used var) t))
  905.        ((lambda-var-specvar var)
  906.     (compiler-warning
  907.      "Declaring special variable ~S to be ignored." name))
  908.        ((eq (first spec) 'ignorable)
  909.     (setf (leaf-ever-used var) t))
  910.        (t
  911.     (setf (lambda-var-ignorep var) t)))))
  912.   (undefined-value))
  913.  
  914.  
  915. (defvar *suppress-values-declaration* nil
  916.   "If true, processing of the VALUES declaration is inhibited.")
  917.  
  918.  
  919. ;;; PROCESS-1-DECLARATION  --  Internal
  920. ;;;
  921. ;;;    Process a single declaration spec, agumenting the specified LEXENV
  922. ;;; Res and returning it as a result.  Vars and Fvars are as described in
  923. ;;; PROCESS-DECLARATIONS.
  924. ;;;
  925. (defun process-1-declaration (spec res vars fvars cont)
  926.   (declare (list spec vars fvars) (type lexenv res) (type continuation cont))
  927.   (case (first spec)
  928.     (special (process-special-declaration spec res vars))
  929.     (ftype
  930.      (unless (cdr spec)
  931.        (compiler-error "No type specified in FTYPE declaration: ~S." spec))
  932.      (process-ftype-declaration (second spec) res (cddr spec) fvars))
  933.     (function
  934.      ;;
  935.      ;; Handle old style FUNCTION declaration, which is an abbreviation for
  936.      ;; FTYPE.  Args are name, arglist, result type.
  937.      (cond ((and (<= 3 (length spec) 4) (listp (third spec)))
  938.         (process-ftype-declaration `(function ,@(cddr spec)) res
  939.                        (list (second spec))
  940.                        fvars))
  941.        (t
  942.         (process-type-declaration spec res vars))))
  943.     ((inline notinline maybe-inline)
  944.      (process-inline-declaration spec res fvars))
  945.     ((ignore ignorable)
  946.      (process-ignore-declaration spec vars fvars)
  947.      res)
  948.     (optimize
  949.      (make-lexenv
  950.       :default res
  951.       :cookie (process-optimize-declaration spec (lexenv-cookie res))))
  952.     (optimize-interface
  953.      (make-lexenv
  954.       :default res
  955.       :interface-cookie (process-optimize-declaration
  956.              spec
  957.              (lexenv-interface-cookie res))))
  958.     (type
  959.      (process-type-declaration (cdr spec) res vars))
  960.     (values
  961.      (if *suppress-values-declaration*
  962.      res
  963.      (let ((types (cdr spec)))
  964.        (do-the-stuff (if (eql (length types) 1)
  965.                  (car types)
  966.                  `(values ,@types))
  967.              cont res 'values))))
  968.     (t
  969.      (let ((what (first spec)))
  970.        (cond ((member what type-specifier-symbols)
  971.           (process-type-declaration spec res vars))
  972.          ((info declaration recognized what)
  973.           res)
  974.          (t
  975.           (compiler-warning "Unrecognized declaration: ~S." spec)
  976.           res))))))
  977.  
  978.  
  979. ;;; Process-Declarations  --  Interface
  980. ;;;
  981. ;;;    Use a list of Declare forms to annotate the lists of Lambda-Var and
  982. ;;; Functional structures which are being bound.  In addition to filling in
  983. ;;; slots in the leaf structures, we return a new LEXENV which reflects
  984. ;;; pervasive special and function type declarations, (not)inline declarations
  985. ;;; and optimize declarations.  Cont is the continuation affected by VALUES
  986. ;;; declarations.
  987. ;;;
  988. ;;; This is also called in main.lisp when PROCESS-FORM handles a use of
  989. ;;; LOCALLY.
  990. ;;;
  991. (defun process-declarations (decls vars fvars cont)
  992.   (declare (list decls vars fvars) (type continuation cont))
  993.   (let ((res *lexical-environment*))
  994.     (dolist (decl decls)
  995.       (dolist (spec (rest decl))
  996.     (unless (consp spec)
  997.       (compiler-error "Malformed declaration specifier ~S in ~S."
  998.               spec decl))
  999.  
  1000.     (setq res (process-1-declaration spec res vars fvars cont))))
  1001.     res))
  1002.  
  1003.  
  1004. ;;; Specvar-For-Binding  --  Internal
  1005. ;;;
  1006. ;;;    Return the Specvar for Name to use when we see a local SPECIAL
  1007. ;;; declaration.  If there is a global variable of that name, then check that
  1008. ;;; it isn't a constant and return it.  Otherwise, create an anonymous
  1009. ;;; GLOBAL-VAR.
  1010. ;;;
  1011. (defun specvar-for-binding (name)
  1012.   (cond ((not (eq (info variable where-from name) :assumed))
  1013.      (let ((found (find-free-variable name)))
  1014.        (when (heap-alien-info-p found)
  1015.          (compiler-error "Declaring an alien variable to be special: ~S"
  1016.                  name))
  1017.        (when (or (not (global-var-p found))
  1018.              (eq (global-var-kind found) :constant))
  1019.          (compiler-error "Declaring a constant to be special: ~S." name))
  1020.        found))
  1021.     (t
  1022.      (make-global-var :kind :special  :name name  :where-from :declared))))
  1023.  
  1024.  
  1025. ;;; IR1-Convert-Aux-Bindings  --  Internal
  1026. ;;;
  1027. ;;;    Similar to IR1-Convert-Progn-Body except that we sequentially bind each
  1028. ;;; Aux-Var to the corresponding Aux-Val before converting the body.  If there
  1029. ;;; are no bindings, just convert the body, otherwise do one binding and
  1030. ;;; recurse on the rest.
  1031. ;;;
  1032. ;;;    If Interface is true, then we convert bindings with the interface
  1033. ;;; policy.  For real &aux bindings, and implicit aux bindings introduced by
  1034. ;;; keyword bindings, this is always true.  It is only false when LET* directly
  1035. ;;; calls this function.
  1036. ;;;
  1037. (defun ir1-convert-aux-bindings (start cont body aux-vars aux-vals interface)
  1038.   (declare (type continuation start cont) (list body aux-vars aux-vals))
  1039.   (if (null aux-vars)
  1040.       (ir1-convert-progn-body start cont body)
  1041.       (let ((fun-cont (make-continuation))
  1042.         (fun (ir1-convert-lambda-body body (list (first aux-vars))
  1043.                       (rest aux-vars) (rest aux-vals))))
  1044.     (reference-leaf start fun-cont fun nil)
  1045.     (let ((*lexical-environment*
  1046.            (if interface
  1047.            (make-lexenv
  1048.             :cookie (make-interface-cookie *lexical-environment*))
  1049.            *lexical-environment*)))
  1050.       (ir1-convert-combination-args fun-cont cont
  1051.                     (list (first aux-vals))))))
  1052.   (undefined-value))
  1053.  
  1054.  
  1055. ;;; IR1-Convert-Special-Bindings  --  Internal
  1056. ;;;
  1057. ;;;    Similar to IR1-Convert-Progn-Body except that code to bind the Specvar
  1058. ;;; for each Svar to the value of the variable is wrapped around the body.  If
  1059. ;;; there are no special bindings, we just convert the body, otherwise we do
  1060. ;;; one special binding and recurse on the rest.
  1061. ;;;
  1062. ;;;    We make a cleanup and introduce it into the lexical environment.  If
  1063. ;;; there are multiple special bindings, the cleanup for the blocks will end up
  1064. ;;; being the innermost one.  We force Cont to start a block outside of this
  1065. ;;; cleanup, causing cleanup code to be emitted when the scope is exited.
  1066. ;;;
  1067. (defun ir1-convert-special-bindings (start cont body aux-vars aux-vals svars)
  1068.   (declare (type continuation start cont)
  1069.        (list body aux-vars aux-vals svars))
  1070.   (cond
  1071.    ((null svars)
  1072.     (ir1-convert-aux-bindings start cont body aux-vars aux-vals t))
  1073.    (t
  1074.     (continuation-starts-block cont)
  1075.     (let ((cleanup (make-cleanup :kind :special-bind))
  1076.       (var (first svars))
  1077.       (next-cont (make-continuation))
  1078.       (nnext-cont (make-continuation)))
  1079.       (ir1-convert start next-cont
  1080.            `(%special-bind ',(lambda-var-specvar var) ,var))
  1081.       (setf (cleanup-mess-up cleanup) (continuation-use next-cont))
  1082.       (let ((*lexical-environment* (make-lexenv :cleanup cleanup)))
  1083.     (ir1-convert next-cont nnext-cont '(%cleanup-point))
  1084.     (ir1-convert-special-bindings nnext-cont cont body aux-vars aux-vals
  1085.                       (rest svars)))))))
  1086.  
  1087.  
  1088. ;;; IR1-Convert-Lambda-Body  --  Internal
  1089. ;;;
  1090. ;;;    Create a lambda node out of some code, returning the result.  The
  1091. ;;; bindings are specified by the list of var structures Vars.  We deal with
  1092. ;;; adding the names to the Lexenv-Variables for the conversion.  The result is
  1093. ;;; added to the New-Functions in the *Current-Component* and linked to the
  1094. ;;; component head and tail.
  1095. ;;;
  1096. ;;; We detect special bindings here, replacing the original Var in the lambda
  1097. ;;; list with a temporary variable.  We then pass a list of the special vars to
  1098. ;;; IR1-Convert-Special-Bindings, which actually emits the special binding
  1099. ;;; code.
  1100. ;;;
  1101. ;;; We ignore any Arg-Info in the Vars, trusting that someone else is dealing
  1102. ;;; with &nonsense.
  1103. ;;;
  1104. ;;; Aux-Vars is a list of Var structures for variables that are to be
  1105. ;;; sequentially bound.  Each Aux-Val is a form that is to be evaluated to get
  1106. ;;; the initial value for the corresponding Aux-Var.
  1107. ;;;
  1108. (defun ir1-convert-lambda-body (body vars &optional aux-vars aux-vals result)
  1109.   (declare (list body vars aux-vars aux-vals)
  1110.        (type (or continuation null) result))
  1111.   (let* ((bind (make-bind))
  1112.      (lambda (make-lambda :vars vars  :bind bind))
  1113.      (result (or result (make-continuation))))
  1114.     (setf (lambda-home lambda) lambda)
  1115.     (collect ((svars)
  1116.           (new-venv nil cons))
  1117.  
  1118.       (dolist (var vars)
  1119.     (setf (lambda-var-home var) lambda)
  1120.     (let ((specvar (lambda-var-specvar var)))
  1121.       (cond (specvar
  1122.          (svars var)
  1123.          (new-venv (cons (leaf-name specvar) specvar)))
  1124.         (t
  1125.          (new-venv (cons (leaf-name var) var))))))
  1126.       
  1127.       (let ((*lexical-environment*
  1128.          (make-lexenv :variables (new-venv)  :lambda lambda
  1129.               :cleanup nil)))
  1130.     (setf (bind-lambda bind) lambda)
  1131.     (setf (node-lexenv bind) *lexical-environment*)
  1132.     
  1133.     (let ((cont1 (make-continuation))
  1134.           (cont2 (make-continuation)))
  1135.       (continuation-starts-block cont1)
  1136.       (prev-link bind cont1)
  1137.       (use-continuation bind cont2)
  1138.       (ir1-convert-special-bindings cont2 result body aux-vars aux-vals
  1139.                     (svars)))
  1140.  
  1141.     (let ((block (continuation-block result)))
  1142.       (when block
  1143.         (let ((return (make-return :result result
  1144.                        :lambda lambda))
  1145.           (tail-set (make-tail-set :functions (list lambda)))
  1146.           (dummy (make-continuation)))
  1147.           (setf (lambda-tail-set lambda) tail-set)
  1148.           (setf (lambda-return lambda) return)
  1149.           (setf (continuation-dest result) return)
  1150.           (setf (block-last block) return)
  1151.           (prev-link return result)
  1152.           (use-continuation return dummy))
  1153.         (link-blocks block (component-tail *current-component*))))))
  1154.  
  1155.     (link-blocks (component-head *current-component*) (node-block bind))
  1156.     (push lambda (component-new-functions *current-component*))
  1157.     lambda))
  1158.  
  1159.  
  1160. ;;; Convert-Optional-Entry  --  Internal
  1161. ;;;
  1162. ;;;    Create the actual entry-point function for an optional entry point.  The
  1163. ;;; lambda binds copies of each of the Vars, then calls Fun with the argument
  1164. ;;; Vals and the Defaults.  Presumably the Vals refer to the Vars by name.  The
  1165. ;;; Vals are passed in in reverse order.
  1166. ;;;
  1167. ;;;    If any of the copies of the vars are referenced more than once, then we
  1168. ;;; mark the corresponding var as Ever-Used to inhibit "defined but not read"
  1169. ;;; warnings for arguments that are only used by default forms.
  1170. ;;;
  1171. ;;;    We bind *lexical-environment* to change the policy over to the interface
  1172. ;;; policy.
  1173. ;;;
  1174. (defun convert-optional-entry (fun vars vals defaults)
  1175.   (declare (type clambda fun) (list vars vals defaults))
  1176.   (let* ((fvars (reverse vars))
  1177.      (arg-vars (mapcar #'(lambda (var)
  1178.                    (make-lambda-var
  1179.                 :name (leaf-name var)
  1180.                 :type (leaf-type var)
  1181.                 :where-from (leaf-where-from var)
  1182.                 :specvar (lambda-var-specvar var)))
  1183.                fvars))
  1184.      (*lexical-environment*
  1185.       (make-lexenv :cookie (make-interface-cookie *lexical-environment*)))
  1186.      (fun
  1187.       (ir1-convert-lambda-body
  1188.        `((%funcall ,fun ,@(reverse vals) ,@defaults))
  1189.        arg-vars)))
  1190.     (mapc #'(lambda (var arg-var)
  1191.           (when (cdr (leaf-refs arg-var))
  1192.         (setf (leaf-ever-used var) t)))
  1193.       fvars arg-vars)
  1194.     fun))
  1195.  
  1196.  
  1197. ;;; Generate-Optional-Default-Entry  --  Internal
  1198. ;;;
  1199. ;;;    This function deals with supplied-p vars in optional arguments.  If the
  1200. ;;; there is no supplied-p arg, then we just call IR1-Convert-Hairy-Args on the
  1201. ;;; remaining arguments, and generate a optional entry that calls the result.
  1202. ;;; If there is a supplied-p var, then we add it into the default vars and
  1203. ;;; throw a T into the entry values.  The resulting entry point function is
  1204. ;;; returned.
  1205. ;;;
  1206. (defun generate-optional-default-entry (res default-vars default-vals
  1207.                         entry-vars entry-vals
  1208.                         vars supplied-p-p body
  1209.                         aux-vars aux-vals cont)
  1210.   (declare (type optional-dispatch res)
  1211.        (list default-vars default-vals entry-vars entry-vals vars body
  1212.          aux-vars aux-vals)
  1213.        (type (or continuation null) cont))
  1214.   (let* ((arg (first vars))
  1215.      (arg-name (leaf-name arg))
  1216.      (info (lambda-var-arg-info arg))
  1217.      (supplied-p (arg-info-supplied-p info))
  1218.      (ep (if supplied-p
  1219.          (ir1-convert-hairy-args
  1220.           res
  1221.           (list* supplied-p arg default-vars)
  1222.           (list* (leaf-name supplied-p) arg-name default-vals)
  1223.           (cons arg entry-vars)
  1224.           (list* t arg-name entry-vals)
  1225.           (rest vars) t body aux-vars aux-vals cont)
  1226.          (ir1-convert-hairy-args 
  1227.           res
  1228.           (cons arg default-vars)
  1229.           (cons arg-name default-vals)
  1230.           (cons arg entry-vars)
  1231.           (cons arg-name entry-vals)
  1232.           (rest vars) supplied-p-p body aux-vars aux-vals cont))))
  1233.          
  1234.     (convert-optional-entry ep default-vars default-vals
  1235.                 (if supplied-p
  1236.                 (list (arg-info-default info) nil)
  1237.                 (list (arg-info-default info))))))
  1238.  
  1239.  
  1240. ;;; Convert-More-Entry  --  Internal
  1241. ;;;
  1242. ;;;    Create the More-Entry function for the Optional-Dispatch Res.
  1243. ;;; Entry-Vars and Entry-Vals describe the fixed arguments.  Rest is the var
  1244. ;;; for any Rest arg.  Keys is a list of the keyword arg vars.
  1245. ;;;
  1246. ;;;    The most interesting thing that we do is parse keywords.  We create a
  1247. ;;; bunch of temporary variables to hold the result of the parse, and then loop
  1248. ;;; over the supplied arguments, setting the appropriate temps for the supplied
  1249. ;;; keyword.  Note that it is significant that we iterate over the keywords in
  1250. ;;; reverse order --- this implements the CL requirement that (when a keyword
  1251. ;;; appears more than once) the first value is used.
  1252. ;;;
  1253. ;;;    If there is no supplied-p var, then we initialize the temp to the
  1254. ;;; default and just pass the temp into the main entry.  Since non-constant
  1255. ;;; keyword args are forcibly given a supplied-p var, we know that the default
  1256. ;;; is constant, and thus safe to evaluate out of order.
  1257. ;;;
  1258. ;;;    If there is a supplied-p var, then we create temps for both the value
  1259. ;;; and the supplied-p, and pass them into the main entry, letting it worry
  1260. ;;; about defaulting.
  1261. ;;;
  1262. ;;;    We deal with :allow-other-keys by delaying unknown keyword errors until
  1263. ;;; we have scanned all the keywords.
  1264. ;;;
  1265. ;;;    When converting the function, we bind *lexical-environment* to change
  1266. ;;; the compilation policy over to the interface policy, so that keyword args
  1267. ;;; will be checked even when type checking isn't on in general.
  1268. ;;;
  1269. (defun convert-more-entry (res entry-vars entry-vals rest keys)
  1270.   (declare (type optional-dispatch res) (list entry-vars entry-vals keys))
  1271.   (collect ((arg-vars)
  1272.         (arg-vals (reverse entry-vals))
  1273.         (temps)
  1274.         (body))
  1275.     
  1276.     (dolist (var (reverse entry-vars))
  1277.       (arg-vars (make-lambda-var
  1278.          :name (leaf-name var)
  1279.          :type (leaf-type var)
  1280.          :where-from (leaf-where-from var))))
  1281.  
  1282.     (let* ((n-context (gensym))
  1283.        (context-temp (make-lambda-var :name n-context))
  1284.        (n-count (gensym))
  1285.        (count-temp (make-lambda-var :name n-count
  1286.                     :type (specifier-type 'fixnum)))
  1287.        (*lexical-environment*
  1288.         (make-lexenv :cookie
  1289.              (make-interface-cookie *lexical-environment*))))
  1290.         
  1291.       (arg-vars context-temp count-temp)
  1292.  
  1293.       (when rest
  1294.     (arg-vals `(%listify-rest-args ,n-context ,n-count)))
  1295.  
  1296.       (when (optional-dispatch-keyp res)
  1297.     (let ((n-index (gensym))
  1298.           (n-key (gensym))
  1299.           (n-value-temp (gensym))
  1300.           (n-allowp (gensym))
  1301.           (n-losep (gensym))
  1302.           (allowp (or (optional-dispatch-allowp res)
  1303.               (policy nil (zerop safety)))))
  1304.       
  1305.       (temps `(,n-index (1- ,n-count)) n-key n-value-temp)
  1306.       (body `(declare (fixnum ,n-index) (ignorable ,n-key ,n-value-temp)))
  1307.  
  1308.       (collect ((tests))
  1309.         (dolist (key keys)
  1310.           (let* ((info (lambda-var-arg-info key))
  1311.              (default (arg-info-default info))
  1312.              (keyword (arg-info-keyword info))
  1313.              (supplied-p (arg-info-supplied-p info))
  1314.              (n-value (gensym)))
  1315.         (temps `(,n-value ,default))
  1316.         (cond (supplied-p
  1317.                (let ((n-supplied (gensym)))
  1318.              (temps n-supplied)
  1319.              (arg-vals n-value n-supplied)
  1320.              (tests `((eq ,n-key ,keyword)
  1321.                   (setq ,n-supplied t)
  1322.                   (setq ,n-value ,n-value-temp)))))
  1323.               (t
  1324.                (arg-vals n-value)
  1325.                (tests `((eq ,n-key ,keyword)
  1326.                 (setq ,n-value ,n-value-temp)))))))
  1327.  
  1328.         (unless allowp
  1329.           (temps n-allowp n-losep)
  1330.           (tests `((eq ,n-key :allow-other-keys)
  1331.                (setq ,n-allowp ,n-value-temp)))
  1332.           (tests `(t
  1333.                (setq ,n-losep ,n-key))))
  1334.  
  1335.         (body
  1336.          `(when (oddp ,n-count)
  1337.         (%odd-keyword-arguments-error)))
  1338.  
  1339.         (body
  1340.          `(locally
  1341.         (declare (optimize (safety 0)))
  1342.         (loop
  1343.           (when (minusp ,n-index) (return))
  1344.           (setf ,n-value-temp (%more-arg ,n-context ,n-index))
  1345.           (decf ,n-index)
  1346.           (setq ,n-key (%more-arg ,n-context ,n-index))
  1347.           (decf ,n-index)
  1348.           (cond ,@(tests)))))
  1349.  
  1350.         (unless allowp
  1351.           (body `(when (and ,n-losep (not ,n-allowp))
  1352.                (%unknown-keyword-argument-error ,n-losep)))))))
  1353.       
  1354.       (let ((ep (ir1-convert-lambda-body
  1355.          `((let ,(temps)
  1356.              ,@(body)
  1357.              (%funcall ,(optional-dispatch-main-entry res)
  1358.                    . ,(arg-vals))))
  1359.          (arg-vars))))
  1360.     (setf (optional-dispatch-more-entry res) ep))))
  1361.  
  1362.   (undefined-value))
  1363.  
  1364.  
  1365. ;;; IR1-Convert-More  --  Internal
  1366. ;;;
  1367. ;;;    Called by IR1-Convert-Hairy-Args when we run into a rest or keyword arg.
  1368. ;;; The arguments are similar to that function, but we split off any rest arg
  1369. ;;; and pass it in separately.  Rest is the rest arg var, or NIL if there is no
  1370. ;;; rest arg.  Keys is a list of the keyword argument vars.
  1371. ;;;
  1372. ;;;    When there are keyword arguments, we introduce temporary gensym
  1373. ;;; variables to hold the values while keyword defaulting is in progress to get
  1374. ;;; the required sequential binding semantics.
  1375. ;;;
  1376. ;;;    This gets interesting mainly when there are keyword arguments with
  1377. ;;; supplied-p vars or non-constant defaults.  In either case, pass in a
  1378. ;;; supplied-p var.  If the default is non-constant, we introduce an IF in the
  1379. ;;; main entry that tests the supplied-p var and decides whether to evaluate
  1380. ;;; the default or not.  In this case, the real incoming value is NIL, so we
  1381. ;;; must union NULL with the declared type when computing the type for the main
  1382. ;;; entry's argument.
  1383. ;;;
  1384. (defun ir1-convert-more (res default-vars default-vals entry-vars entry-vals
  1385.                  rest keys supplied-p-p body aux-vars aux-vals
  1386.                  cont)
  1387.   (declare (type optional-dispatch res)
  1388.        (list default-vars default-vals entry-vars entry-vals keys body
  1389.          aux-vars aux-vals)
  1390.        (type (or continuation null) cont))
  1391.   (collect ((main-vars (reverse default-vars))
  1392.         (main-vals default-vals cons)
  1393.         (bind-vars)
  1394.         (bind-vals))
  1395.     (when rest
  1396.       (main-vars rest)
  1397.       (main-vals '()))
  1398.  
  1399.     (dolist (key keys)
  1400.       (let* ((info (lambda-var-arg-info key))
  1401.          (default (arg-info-default info))
  1402.          (hairy-default (not (compiler-constantp default)))
  1403.          (supplied-p (arg-info-supplied-p info))
  1404.          (n-val (make-symbol (format nil "~A-DEFAULTING-TEMP"
  1405.                      (leaf-name key))))
  1406.          (key-type (leaf-type key))
  1407.          (val-temp (make-lambda-var
  1408.             :name n-val
  1409.             :type (if hairy-default
  1410.                   (type-union key-type (specifier-type 'null))
  1411.                   key-type))))
  1412.     (main-vars val-temp)
  1413.     (bind-vars key)
  1414.     (cond ((or hairy-default supplied-p)
  1415.            (let* ((n-supplied (gensym))
  1416.               (supplied-temp (make-lambda-var :name n-supplied)))
  1417.          (unless supplied-p
  1418.            (setf (arg-info-supplied-p info) supplied-temp))
  1419.          (when hairy-default
  1420.            (setf (arg-info-default info) nil))
  1421.          (main-vars supplied-temp)
  1422.          (cond (hairy-default
  1423.             (main-vals nil nil)
  1424.             (bind-vals `(if ,n-supplied ,n-val ,default)))
  1425.                (t
  1426.             (main-vals default nil)
  1427.             (bind-vals n-val)))
  1428.          (when supplied-p
  1429.            (bind-vars supplied-p)
  1430.            (bind-vals n-supplied))))
  1431.           (t
  1432.            (main-vals (arg-info-default info))
  1433.            (bind-vals n-val)))))
  1434.  
  1435.     (let* ((main-entry (ir1-convert-lambda-body body (main-vars)
  1436.                         (append (bind-vars) aux-vars)
  1437.                         (append (bind-vals) aux-vals)
  1438.                         cont))
  1439.        (last-entry (convert-optional-entry main-entry default-vars
  1440.                            (main-vals) ())))
  1441.       (setf (optional-dispatch-main-entry res) main-entry)
  1442.       (convert-more-entry res entry-vars entry-vals rest keys)
  1443.  
  1444.       (push (if supplied-p-p
  1445.         (convert-optional-entry last-entry entry-vars entry-vals ())
  1446.         last-entry)
  1447.         (optional-dispatch-entry-points res))
  1448.       last-entry)))
  1449.  
  1450.  
  1451. ;;; IR1-Convert-Hairy-Args  --  Internal
  1452. ;;;
  1453. ;;;    This function generates the entry point functions for the
  1454. ;;; optional-dispatch Res.  We accomplish this by recursion on the list of
  1455. ;;; arguments, analyzing the arglist on the way down and generating entry
  1456. ;;; points on the way up.
  1457. ;;;
  1458. ;;;    Default-Vars is a reversed list of all the argument vars processed so
  1459. ;;; far, including supplied-p vars.  Default-Vals is a list of the names of the
  1460. ;;; Default-Vars.
  1461. ;;;
  1462. ;;;    Entry-Vars is a reversed list of processed argument vars, excluding
  1463. ;;; supplied-p vars.  Entry-Vals is a list things that can be evaluated to get
  1464. ;;; the values for all the vars from the Entry-Vars.  It has the var name for
  1465. ;;; each required or optional arg, and has T for each supplied-p arg.
  1466. ;;;
  1467. ;;;    Vars is a list of the Lambda-Var structures for arguments that haven't
  1468. ;;; been processed yet.  Supplied-p-p is true if a supplied-p argument has
  1469. ;;; already been processed; only in this case are the Default-XXX and Entry-XXX
  1470. ;;; different.
  1471. ;;;
  1472. ;;;    The result at each point is a lambda which should be called by the above
  1473. ;;; level to default the remaining arguments and evaluate the body.  We cause
  1474. ;;; the body to be evaluated by converting it and returning it as the result
  1475. ;;; when the recursion bottoms out.
  1476. ;;;
  1477. ;;;    Each level in the recursion also adds its entry point function to the
  1478. ;;; result Optional-Dispatch.  For most arguments, the defaulting function and
  1479. ;;; the entry point function will be the same, but when supplied-p args are
  1480. ;;; present they may be different.
  1481. ;;;
  1482. ;;;     When we run into a rest or keyword arg, we punt out to
  1483. ;;; IR1-Convert-More, which finishes for us in this case.
  1484. ;;;
  1485. (defun ir1-convert-hairy-args (res default-vars default-vals
  1486.                    entry-vars entry-vals
  1487.                    vars supplied-p-p body aux-vars
  1488.                    aux-vals cont)
  1489.   (declare (type optional-dispatch res)
  1490.        (list default-vars default-vals entry-vars entry-vals vars body
  1491.          aux-vars aux-vals)
  1492.        (type (or continuation null) cont))
  1493.   (cond ((not vars)
  1494.      (if (optional-dispatch-keyp res)
  1495.          ;;
  1496.          ;; Handle &key with no keys...
  1497.          (ir1-convert-more res default-vars default-vals
  1498.                    entry-vars entry-vals
  1499.                    nil vars supplied-p-p body aux-vars
  1500.                    aux-vals cont)
  1501.          (let ((fun (ir1-convert-lambda-body body (reverse default-vars)
  1502.                          aux-vars aux-vals cont)))
  1503.            (setf (optional-dispatch-main-entry res) fun)
  1504.            (push (if supplied-p-p
  1505.              (convert-optional-entry fun entry-vars entry-vals ())
  1506.              fun)
  1507.              (optional-dispatch-entry-points res))
  1508.            fun)))
  1509.     ((not (lambda-var-arg-info (first vars)))
  1510.      (let* ((arg (first vars))
  1511.         (nvars (cons arg default-vars))
  1512.         (nvals (cons (leaf-name arg) default-vals)))
  1513.        (ir1-convert-hairy-args res nvars nvals nvars nvals
  1514.                    (rest vars) nil body aux-vars aux-vals
  1515.                    cont)))
  1516.     (t
  1517.      (let* ((arg (first vars))
  1518.         (info (lambda-var-arg-info arg))
  1519.         (kind (arg-info-kind info)))
  1520.        (ecase kind
  1521.          (:optional
  1522.           (let ((ep (generate-optional-default-entry
  1523.              res default-vars default-vals
  1524.              entry-vars entry-vals vars supplied-p-p body
  1525.              aux-vars aux-vals cont)))
  1526.         (push (if supplied-p-p
  1527.               (convert-optional-entry ep entry-vars entry-vals ())
  1528.               ep)
  1529.               (optional-dispatch-entry-points res))
  1530.         ep))
  1531.          (:rest
  1532.           (ir1-convert-more res default-vars default-vals
  1533.                 entry-vars entry-vals
  1534.                 arg (rest vars) supplied-p-p body
  1535.                 aux-vars aux-vals cont))
  1536.          (:keyword
  1537.           (ir1-convert-more res default-vars default-vals
  1538.                 entry-vars entry-vals
  1539.                 nil vars supplied-p-p body aux-vars
  1540.                 aux-vals cont)))))))
  1541.  
  1542.  
  1543. ;;; IR1-Convert-Hairy-Lambda  --  Internal
  1544. ;;;
  1545. ;;;     This function deals with the case where we have to make an
  1546. ;;; Optional-Dispatch to represent a lambda.  We cons up the result and call
  1547. ;;; IR1-Convert-Hairy-Args to do the work.  When it is done, we figure out the
  1548. ;;; min-args and max-args. 
  1549. ;;;
  1550. (defun ir1-convert-hairy-lambda (body vars keyp allowp aux-vars aux-vals cont)
  1551.   (declare (list body vars aux-vars aux-vals) (type continuation cont))
  1552.   (let ((res (make-optional-dispatch :arglist vars  :allowp allowp
  1553.                      :keyp keyp))
  1554.     (min (or (position-if #'lambda-var-arg-info vars) (length vars))))
  1555.     (push res (component-new-functions *current-component*))
  1556.     (ir1-convert-hairy-args res () () () () vars nil body aux-vars aux-vals
  1557.                 cont)
  1558.     (setf (optional-dispatch-min-args res) min)
  1559.     (setf (optional-dispatch-max-args res)
  1560.       (+ (1- (length (optional-dispatch-entry-points res))) min))
  1561.  
  1562.     (flet ((frob (ep)
  1563.          (when ep
  1564.            (setf (functional-kind ep) :optional)
  1565.            (setf (leaf-ever-used ep) t)
  1566.            (setf (lambda-optional-dispatch ep) res))))
  1567.       (dolist (ep (optional-dispatch-entry-points res)) (frob ep))
  1568.       (frob (optional-dispatch-more-entry res))
  1569.       (frob (optional-dispatch-main-entry res)))
  1570.       
  1571.     res))
  1572.     
  1573.     
  1574. ;;; IR1-Convert-Lambda  --  Internal
  1575. ;;;
  1576. ;;;    Convert a Lambda into a Lambda or Optional-Dispatch leaf.  Name and
  1577. ;;; Parent-Form are context that is used to drive the context sensitive
  1578. ;;; declaration mechanism.  If we find an entry in *context-declarations* that
  1579. ;;; matches this context (by returning a non-null value) then we add it into
  1580. ;;; the local declarations.
  1581. ;;;
  1582. (defun ir1-convert-lambda (form &optional name parent-form)
  1583.   (unless (and (consp form) (eq (car form) 'lambda) (consp (cdr form))
  1584.            (listp (cadr form)))
  1585.     (compiler-error "Malformed lambda expression: ~S." form))
  1586.  
  1587.   (multiple-value-bind (vars keyp allow-other-keys aux-vars aux-vals)
  1588.                (find-lambda-vars (cadr form))
  1589.     (multiple-value-bind
  1590.     (body decls)
  1591.     (system:parse-body (cddr form) *lexical-environment* t)
  1592.       (let* ((context-decls
  1593.           (and parent-form
  1594.            (loop for fun in *context-declarations*
  1595.                  append (funcall fun name parent-form))))
  1596.          (cont (make-continuation))
  1597.          (*lexical-environment*
  1598.           (process-declarations (append context-decls decls)
  1599.                     (append aux-vars vars)
  1600.                     nil cont))
  1601.          (res (if (or (find-if #'lambda-var-arg-info vars) keyp)
  1602.               (ir1-convert-hairy-lambda body vars keyp
  1603.                         allow-other-keys
  1604.                         aux-vars aux-vals cont)
  1605.               (ir1-convert-lambda-body body vars aux-vars aux-vals
  1606.                            cont))))
  1607.     (setf (functional-inline-expansion res) form)
  1608.     (setf (functional-arg-documentation res) (cadr form))
  1609.     res))))
  1610.  
  1611.  
  1612. ;;;; Variable hacking:
  1613.  
  1614.  
  1615. (defvar *derive-function-types* t
  1616.   "If true, argument and result type information derived from compilation of
  1617.   DEFUNs is used when compiling calls to that function.  If false, only
  1618.   information from FTYPE proclamations will be used.")
  1619.  
  1620.  
  1621. ;;; Find-Free-Really-Function  --  Internal
  1622. ;;;
  1623. ;;;    Return a Global-Var structure usable for referencing the global function
  1624. ;;; Name.
  1625. ;;;
  1626. (defun find-free-really-function (name)
  1627.   (unless (info function kind name)
  1628.     (setf (info function kind name) :function)
  1629.     (setf (info function where-from name) :assumed))
  1630.   
  1631.   (when (eq (info function where-from name) :assumed)
  1632.     (note-undefined-reference name :function))
  1633.   
  1634.   (let ((where (info function where-from name)))
  1635.     (make-global-var :kind :global-function  :name name
  1636.              :type (if (or *derive-function-types*
  1637.                    (eq where :declared))
  1638.                    (info function type name)
  1639.                    (specifier-type 'function))
  1640.              :where-from where)))
  1641.  
  1642.  
  1643. ;;; Find-Slot-Accessor  --  Internal
  1644. ;;;
  1645. ;;;    Return a Slot-Accessor structure usable for referencing the slot
  1646. ;;; accessor Name.  Info is the structure definition.
  1647. ;;;
  1648. (defun find-slot-accessor (info name)
  1649.   (declare (type defstruct-description info))
  1650.   (let* ((accessor (if (listp name) (cadr name) name))
  1651.      (slot (find accessor (dd-slots info)
  1652.              :key #'dsd-accessor))
  1653.      (type (dd-name info))
  1654.      (slot-type (dsd-type slot)))
  1655.     (assert slot () "Can't find slot ~S." type)
  1656.     (make-slot-accessor
  1657.      :name name
  1658.      :type (specifier-type
  1659.         (if (listp name)
  1660.         `(function (,slot-type ,type) ,slot-type)
  1661.         `(function (,type) ,slot-type)))
  1662.      :for info
  1663.      :slot slot)))
  1664.  
  1665.  
  1666. ;;; Find-Free-Function  --  Internal
  1667. ;;;
  1668. ;;;    If Name is already entered in *free-functions*, then return the value.
  1669. ;;; Otherwise, make a new Global-Var using information from the global
  1670. ;;; environment and enter it in *free-functions*.  If Name names a macro or
  1671. ;;; special form, then we error out using the supplied context which indicates
  1672. ;;; what we were trying to do that demanded a function.  The second value is
  1673. ;;; the inlinep information which currently applies to the variable.
  1674. ;;;
  1675. (proclaim '(function find-free-function (t string) (values global-var inlinep)))
  1676. (defun find-free-function (name context)
  1677.   (let ((found (gethash name *free-functions*)))
  1678.     (cond
  1679.      (found
  1680.       (assert (not (and (typep found 'functional)
  1681.             (member (functional-kind found)
  1682.                 '(:deleted :let :mv-let)))))
  1683.       (values found (leaf-inlinep found)))
  1684.      (t
  1685.       (ecase (info function kind name)
  1686.     (:macro
  1687.      (compiler-error "Found macro name ~S ~A." name context))
  1688.     (:special-form
  1689.      (compiler-error "Found special-form name ~S ~A." name context))
  1690.     ((:function nil)
  1691.      (check-function-name name)
  1692.      (note-if-setf-function-and-macro name)
  1693.      (let ((info (info function accessor-for name)))
  1694.        (values (setf (gethash name *free-functions*)
  1695.              (if info
  1696.                  (find-slot-accessor info name)
  1697.                  (find-free-really-function name)))
  1698.            (info function inlinep name)))))))))
  1699.  
  1700.  
  1701. ;;; IR1-Convert-Variable  --  Internal
  1702. ;;;
  1703. ;;;    Convert a reference to a symbolic constant or variable.  If the symbol
  1704. ;;; is entered in the LEXENV-VARIABLES we use that definition, otherwise we
  1705. ;;; find the current global definition.  This is also where we pick off symbol
  1706. ;;; macro and Alien variable references.
  1707. ;;;
  1708. (defun ir1-convert-variable (start cont name)
  1709.   (declare (type continuation start cont) (symbol name))
  1710.   (let ((var (or (lexenv-find name variables) (find-free-variable name))))
  1711.     (etypecase var
  1712.       (leaf
  1713.        (when (and (lambda-var-p var) (lambda-var-ignorep var))
  1714.      (compiler-warning "Reading an ignored variable: ~S." name))
  1715.        (reference-leaf start cont var nil))
  1716.       (cons
  1717.        (assert (eq (car var) 'MACRO))
  1718.        (ir1-convert start cont (cdr var)))
  1719.       (heap-alien-info
  1720.        (ir1-convert start cont `(%heap-alien ',var)))))
  1721.   (undefined-value))
  1722.  
  1723.  
  1724. ;;; Find-Free-Variable  --  Internal
  1725. ;;;
  1726. ;;;    Return the Leaf node for a global variable reference to Name.  If Name
  1727. ;;; is already entered in *free-variables*, then we just return the
  1728. ;;; corresponding value.  Otherwise, we make a new leaf using information from
  1729. ;;; the global environment and enter it in *free-variables*.  If the variable
  1730. ;;; is unknown, then we emit a warning.
  1731. ;;;
  1732. (defun find-free-variable (name)
  1733.   (declare (values (or leaf heap-alien-info)))
  1734.   (unless (symbolp name)
  1735.     (compiler-error "Variable name is not a symbol: ~S." name))
  1736.   (or (gethash name *free-variables*)
  1737.       (let ((kind (info variable kind name))
  1738.         (type (info variable type name))
  1739.         (where-from (info variable where-from name)))
  1740.     (when (and (eq where-from :assumed) (eq kind :global))
  1741.       (note-undefined-reference name :variable))
  1742.  
  1743.     (setf (gethash name *free-variables*)
  1744.           (if (eq kind :alien)
  1745.           (info variable alien-info name)
  1746.           (multiple-value-bind
  1747.               (val valp)
  1748.               (info variable constant-value name)
  1749.             (if (and (eq kind :constant) valp)
  1750.             (make-constant :value val  :name name
  1751.                        :type (ctype-of val)
  1752.                        :where-from where-from)
  1753.             (make-global-var :kind kind  :name name  :type type
  1754.                      :where-from where-from))))))))
  1755.  
  1756.  
  1757. ;;; Reference-Constant  --  Internal
  1758. ;;;
  1759. ;;; Generate a reference to a manifest constant, creating a new leaf if
  1760. ;;; necessary.  If we are producing a fasl-file, make sure MAKE-LOAD-FORM
  1761. ;;; gets used on any parts of the constant that it needs to be.
  1762. ;;;
  1763. (defun reference-constant (start cont value)
  1764.   (declare (type continuation start cont))
  1765.   (ir1-error-bailout
  1766.       (start cont value
  1767.        '(error "Attempt to reference undumpable constant."))
  1768.     (when (producing-fasl-file)
  1769.       (maybe-emit-make-load-forms value))
  1770.     (let* ((leaf (find-constant value))
  1771.        (res (make-ref (leaf-type leaf) leaf nil)))
  1772.       (push res (leaf-refs leaf))
  1773.       (prev-link res start)
  1774.       (use-continuation res cont)))
  1775.   (undefined-value))
  1776.  
  1777. ;;; MAYBE-EMIT-MAKE-LOAD-FORMS  --  internal
  1778. ;;;
  1779. ;;; Grovel over CONSTANT checking for any sub-parts that need to be processed
  1780. ;;; with MAKE-LOAD-FORM.  We have to be careful, because CONSTANT might be
  1781. ;;; circular.  We also check that the constant (and any subparts) are dumpable
  1782. ;;; at all.
  1783. ;;; 
  1784. (defconstant list-to-hash-table-threshold 32)
  1785. ;;;
  1786. (defun maybe-emit-make-load-forms (constant)
  1787.   (let ((things-processed nil)
  1788.     (count 0))
  1789.     (declare (type (or list hash-table) things-processed)
  1790.          (type (integer 0 #.(1+ list-to-hash-table-threshold)) count))
  1791.     (labels ((grovel (value)
  1792.            (etypecase things-processed
  1793.          (list
  1794.           (when (member value things-processed)
  1795.             (return-from grovel nil))
  1796.           (push value things-processed)
  1797.           (incf count)
  1798.           (when (> count list-to-hash-table-threshold)
  1799.             (let ((things things-processed))
  1800.               (setf things-processed
  1801.                 (make-hash-table :test #'eq))
  1802.               (dolist (thing things)
  1803.             (setf (gethash thing things-processed) t)))))
  1804.          (hash-table
  1805.           (when (gethash value things-processed)
  1806.             (return-from grovel nil))
  1807.           (setf (gethash value things-processed) t)))
  1808.            (typecase value
  1809.          (cons
  1810.           (grovel (car value))
  1811.           (grovel (cdr value)))
  1812.          ((or symbol number character unboxed-array))
  1813.          (simple-vector
  1814.           (dotimes (i (length value))
  1815.             (grovel (svref value i))))
  1816.          ((vector t)
  1817.           (dotimes (i (length value))
  1818.             (grovel (aref value i))))
  1819.          ((simple-array t)
  1820.           ;; Even though the (array t) branch does the exact same
  1821.           ;; thing as this branch we do this seperate so that
  1822.           ;; the compiler can use faster versions of array-total-size
  1823.           ;; and row-major-aref.
  1824.           (dotimes (i (array-total-size value))
  1825.             (grovel (row-major-aref value i))))
  1826.          ((array t)
  1827.           (dotimes (i (array-total-size value))
  1828.             (grovel (row-major-aref value i))))
  1829.          (structure
  1830.           (when (emit-make-load-form value)
  1831.             (dotimes (i (structure-length value))
  1832.               (grovel (structure-ref value i)))))
  1833.          (t
  1834.           (compiler-error
  1835.            "Cannot dump objects of type ~S into fasl files."
  1836.            (type-of value))))))
  1837.       (grovel constant)))
  1838.   (undefined-value))
  1839.  
  1840.  
  1841. ;;; Reference-Leaf  --  Internal
  1842. ;;;
  1843. ;;;    Generate a Ref node for a Leaf, frobbing the Leaf structure as
  1844. ;;; needed.  Inlinep specifies the legality of inline coding for a 
  1845. ;;; function-valued variable. 
  1846. ;;;
  1847. (proclaim '(function reference-leaf
  1848.              (continuation continuation leaf inlinep)
  1849.              void))
  1850. (defun reference-leaf (start cont leaf inlinep)
  1851.   (let ((res (make-ref (or (lexenv-find leaf type-restrictions)
  1852.                (leaf-type leaf))
  1853.                leaf
  1854.                inlinep)))
  1855.     (push res (leaf-refs leaf))
  1856.     (setf (leaf-ever-used leaf) t)
  1857.     (prev-link res start)
  1858.     (use-continuation res cont)))
  1859.  
  1860.  
  1861. ;;; Set-Variable  --  Internal
  1862. ;;;
  1863. ;;;    Kind of like Reference-Leaf, but we generate a Set node.  This
  1864. ;;; should only need to be called in Setq.
  1865. ;;;
  1866. (defun set-variable (start cont var value)
  1867.   (declare (type continuation start cont) (type basic-var var))
  1868.   (let ((dest (make-continuation)))
  1869.     (setf (continuation-asserted-type dest) (leaf-type var))
  1870.     (ir1-convert start dest value)
  1871.     (let ((res (make-set :var var :value dest)))
  1872.       (setf (continuation-dest dest) res)
  1873.       (setf (leaf-ever-used var) t)
  1874.       (push res (basic-var-sets var))
  1875.       (prev-link res dest)
  1876.       (use-continuation res cont))))
  1877.       
  1878.  
  1879. ;;;; Some flow-graph hacking utilities:
  1880.  
  1881. ;;; Prev-Link  --  Internal
  1882. ;;;
  1883. ;;;    This function sets up the back link between the node and the
  1884. ;;; continuation which continues at it. 
  1885. ;;;
  1886. (proclaim '(function prev-link (node continuation) void))
  1887. (defun prev-link (node cont)
  1888.   (assert (not (continuation-next cont)) () "~S already has a next." cont)
  1889.   (assert (not (node-prev node)) () "Garbage in Prev for ~S." node)
  1890.   (setf (continuation-next cont) node)
  1891.   (setf (node-prev node) cont))
  1892.  
  1893.  
  1894. ;;; Use-Continuation  --  Internal
  1895. ;;;
  1896. ;;;    This function is used to set the continuation for a node, and thus
  1897. ;;; determine what recieves the value and what is evaluated next.  If the
  1898. ;;; continuation has no block, then we make it be in the block that the node is
  1899. ;;; in.  If the continuation heads its block, we end our block and link it to
  1900. ;;; that block.  If the continuation is not currently used, then we set the
  1901. ;;; derived-type for the continuation to that of the node, so that a little
  1902. ;;; type propagation gets done.
  1903. ;;;
  1904. ;;;    We also deal with a bit of THE's semantics here: we weaken the assertion
  1905. ;;; on Cont to be no stronger than the assertion on Cont in our scope.  See the
  1906. ;;; THE IR1-CONVERT method.
  1907. ;;;
  1908. (proclaim '(function use-continuation (node continuation) void))
  1909. (defun use-continuation (node cont)
  1910.   (let ((block (continuation-block cont))
  1911.     (node-block (continuation-block (node-prev node))))
  1912.     (assert (not (node-cont node)) () "Garbage in Cont for ~S." node)
  1913.     (ecase (continuation-kind cont)
  1914.       (:unused
  1915.        (setf (continuation-block cont) node-block)
  1916.        (setf (continuation-kind cont) :inside-block)
  1917.        (setf (continuation-use cont) node)
  1918.        (setf (node-cont node) cont))
  1919.       (:block-start
  1920.        (assert (not (block-last node-block)) () "~S has already ended."
  1921.            node-block)
  1922.        (setf (block-last node-block) node)
  1923.        (assert (null (block-succ node-block)) () "~S already has successors."
  1924.            node-block)
  1925.        (setf (block-succ node-block) (list block))
  1926.        (assert (not (member node-block (block-pred block))) ()
  1927.            "~S is already a predecessor of ~S." node-block block)
  1928.        (push node-block (block-pred block))
  1929.        (add-continuation-use node cont)
  1930.        (unless (eq (continuation-asserted-type cont) *wild-type*)
  1931.      (setf (continuation-asserted-type cont)
  1932.            (values-type-union (continuation-asserted-type cont)
  1933.                   (or (lexenv-find cont type-restrictions)
  1934.                       *wild-type*))))))))
  1935.  
  1936.  
  1937. ;;; Continuation-Starts-Block  --  Internal
  1938. ;;;
  1939. ;;;    Return the block that Continuation is the start of, making a block if
  1940. ;;; necessary.  This function is called by IR1 translators which may cause a
  1941. ;;; continuation to be used more than once.  Every continuation which may be
  1942. ;;; used more than once must start a block by the time that anyone does a
  1943. ;;; Use-Continuation on it.
  1944. ;;; 
  1945. ;;;    We also throw the block into the next/prev list for the
  1946. ;;; *current-component* so that we keep track of which blocks we have made.
  1947. ;;;
  1948. (defun continuation-starts-block (cont)
  1949.   (declare (type continuation cont))
  1950.   (ecase (continuation-kind cont)
  1951.     (:unused
  1952.      (assert (not (continuation-block cont)))
  1953.      (let* ((head (component-head *current-component*))
  1954.         (next (block-next head))
  1955.         (new-block (make-block cont)))
  1956.        (setf (block-next new-block) next)
  1957.        (setf (block-prev new-block) head)
  1958.        (setf (block-prev next) new-block)
  1959.        (setf (block-next head) new-block)
  1960.        (setf (continuation-block cont) new-block)
  1961.        (setf (continuation-use cont) nil)
  1962.        (setf (continuation-kind cont) :block-start)
  1963.        new-block))
  1964.     (:block-start
  1965.      (continuation-block cont))))
  1966.  
  1967.  
  1968. ;;;; Exported functions:
  1969.  
  1970. ;;; IR1-Top-Level  --  Interface
  1971. ;;;
  1972. ;;;    This function takes a form and the top-level form number for that form,
  1973. ;;; and returns a lambda representing the translation of that form in the
  1974. ;;; current global environment.  The lambda is top-level lambda that can be
  1975. ;;; called to cause evaluation of the forms.  This lambda is in the initial
  1976. ;;; component.  If For-Value is T, then the value of the form is returned from
  1977. ;;; the function, otherwise NIL is returned.
  1978. ;;;
  1979. ;;;    This function may have arbitrary effects on the global environment due
  1980. ;;; to processing of Proclaims and Eval-Whens.  All syntax error checking is
  1981. ;;; done, with erroneous forms being replaced by a proxy which signals an error
  1982. ;;; if it is evaluated.  Warnings about possibly inconsistent or illegal
  1983. ;;; changes to the global environment will also be given.
  1984. ;;;
  1985. ;;;    We make the initial component and convert the form in a progn (and an
  1986. ;;; optional NIL tacked on the end.)  We then return the lambda.  We bind all
  1987. ;;; of our state variables here, rather than relying on the global value (if
  1988. ;;; any) so that IR1 conversion will be reentrant.  This is necessary for
  1989. ;;; eval-when processing, etc.
  1990. ;;;
  1991. ;;;    The hashtables used to hold global namespace info must be reallocated
  1992. ;;; elsewhere.  Note also that *lexical-environment* is not bound, so that
  1993. ;;; local macro definitions can be introduced by enclosing code.
  1994. ;;;
  1995. (defun ir1-top-level (form path for-value)
  1996.   (declare (list path))
  1997.   (let* ((*current-path* path)
  1998.      (component (make-empty-component))
  1999.      (*current-component* component))
  2000.     (setf (component-name component) "initial component")
  2001.     (setf (component-kind component) :initial)
  2002.     (let* ((forms (if for-value `(,form) `(,form nil)))
  2003.        (res (ir1-convert-lambda-body forms ())))
  2004.       (setf (leaf-name res) "Top-Level Form")
  2005.       (setf (functional-entry-function res) res)
  2006.       (setf (functional-arg-documentation res) ())
  2007.       (setf (functional-kind res) :top-level)
  2008.       res)))
  2009.  
  2010.  
  2011. ;;; *CURRENT-FORM-NUMBER* is used in FIND-SOURCE-PATHS to compute the form
  2012. ;;; number to associate with a source path.  This should be bound to 0 around
  2013. ;;; the processing of each truly top-level form.
  2014. ;;;
  2015. (proclaim '(type index *current-form-number*))
  2016. (defvar *current-form-number*)
  2017.  
  2018. ;;; Find-Source-Paths  --  Interface
  2019. ;;;
  2020. ;;;    This function is called on freshly read forms to record the initial
  2021. ;;; location of each form (and subform.)  Form is the form to find the paths
  2022. ;;; in, and TLF-Num is the top-level form number of the truly top-level form.
  2023. ;;;
  2024. ;;;    This gets a bit interesting when the source code is circular.  This can
  2025. ;;; (reasonably?) happen in the case of circular list constants. 
  2026. ;;;
  2027. (defun find-source-paths (form tlf-num)
  2028.   (declare (type index tlf-num))
  2029.   (let ((*current-form-number* 0))
  2030.     (sub-find-source-paths form (list tlf-num)))
  2031.   (undefined-value))
  2032. ;;;
  2033. (defun sub-find-source-paths (form path)
  2034.   (unless (gethash form *source-paths*)
  2035.     (setf (gethash form *source-paths*)
  2036.       (list* 'original-source-start *current-form-number* path))
  2037.     (incf *current-form-number*)
  2038.     (let ((pos 0)
  2039.       (subform form)
  2040.       (trail form))
  2041.       (declare (fixnum pos))
  2042.       (macrolet ((frob ()
  2043.            '(progn
  2044.               (when (atom subform) (return))
  2045.               (let ((fm (car subform)))
  2046.             (when (consp fm)
  2047.               (sub-find-source-paths fm (cons pos path)))
  2048.             (incf pos))
  2049.               (setq subform (cdr subform))
  2050.               (when (eq subform trail) (return)))))
  2051.     (loop
  2052.       (frob)
  2053.       (frob)
  2054.       (setq trail (cdr trail)))))))
  2055.  
  2056.  
  2057. ;;;; Control special forms:
  2058.  
  2059. (def-ir1-translator progn ((&rest forms) start cont)
  2060.   "Progn Form*
  2061.   Evaluates each Form in order, returing the values of the last form.  With no
  2062.   forms, returns NIL."
  2063.   (ir1-convert-progn-body start cont forms))
  2064.  
  2065. (def-ir1-translator if ((test then &optional else) start cont)
  2066.   "If Predicate Then [Else]
  2067.   If Predicate evaluates to non-null, evaluate Then and returns its values,
  2068.   otherwise evaluate Else and return its values.  Else defaults to NIL."
  2069.   (let* ((pred (make-continuation))
  2070.      (then-cont (make-continuation))
  2071.      (then-block (continuation-starts-block then-cont))
  2072.      (else-cont (make-continuation))
  2073.      (else-block (continuation-starts-block else-cont))
  2074.      (dummy-cont (make-continuation))
  2075.      (node (make-if :test pred
  2076.             :consequent then-block  :alternative else-block)))
  2077.     (setf (continuation-dest pred) node)
  2078.     (ir1-convert start pred test)
  2079.     (prev-link node pred)
  2080.     (use-continuation node dummy-cont)
  2081.     
  2082.     (let ((start-block (continuation-block pred)))
  2083.       (setf (block-last start-block) node)
  2084.       (continuation-starts-block cont)
  2085.       
  2086.       (link-blocks start-block then-block)
  2087.       (link-blocks start-block else-block)
  2088.       
  2089.       (ir1-convert then-cont cont then)
  2090.       (ir1-convert else-cont cont else))))
  2091.  
  2092.  
  2093. ;;;; Block and Tagbody:
  2094. ;;;
  2095. ;;;    We make an Entry node to mark the start and a :Entry cleanup to
  2096. ;;; mark its extent.  When doing Go or Return-From, we emit an Exit node.
  2097. ;;; 
  2098.  
  2099. ;;; Block IR1 convert  --  Internal
  2100. ;;;
  2101. ;;;    Make a :entry cleanup and emit an Entry node, then convert the body in
  2102. ;;; the modified environment.  We make Cont start a block now, since if it was
  2103. ;;; done later, the block would be in the wrong environment.
  2104. ;;;
  2105. (def-ir1-translator block ((name &rest forms) start cont)
  2106.   "Block Name Form*
  2107.   Evaluate the Forms as a PROGN.  Within the lexical scope of the body,
  2108.   (RETURN-FROM Name Value-Form) can be used to exit the form, returning the
  2109.   result of Value-Form."
  2110.   (unless (symbolp name)
  2111.     (compiler-error "Block name is not a symbol: ~S." name))
  2112.   (continuation-starts-block cont)
  2113.   (let* ((dummy (make-continuation))
  2114.      (entry (make-entry))
  2115.      (cleanup (make-cleanup :kind :block  :mess-up entry)))
  2116.     (push entry (lambda-entries (lexenv-lambda *lexical-environment*)))
  2117.     (setf (entry-cleanup entry) cleanup)
  2118.     (prev-link entry start)
  2119.     (use-continuation entry dummy)
  2120.     (let ((*lexical-environment*
  2121.        (make-lexenv :blocks (list (cons name (list entry cont)))
  2122.             :cleanup cleanup)))
  2123.       (ir1-convert-progn-body dummy cont forms))))
  2124.  
  2125. ;;; We make Cont start a block just so that it will have a block assigned.
  2126. ;;; People assume that when they pass a continuation into IR1-Convert as Cont,
  2127. ;;; it will have a block when it is done.
  2128. ;;;
  2129. (def-ir1-translator return-from ((name &optional value)
  2130.                  start cont)
  2131.   "Return-From Block-Name Value-Form
  2132.   Evaluate the Value-Form, returning its values from the lexically enclosing
  2133.   BLOCK Block-Name.  This is constrained to be used only within the dynamic
  2134.   extent of the BLOCK."
  2135.   (continuation-starts-block cont)
  2136.   (let* ((found (or (lexenv-find name blocks)
  2137.             (compiler-error "Return for unknown block: ~S." name)))
  2138.      (value-cont (make-continuation))
  2139.      (entry (first found))
  2140.      (exit (make-exit :entry entry  :value value-cont)))
  2141.     (push exit (entry-exits entry))
  2142.     (setf (continuation-dest value-cont) exit)
  2143.     (ir1-convert start value-cont value)
  2144.     (prev-link exit value-cont)
  2145.     (use-continuation exit (second found))))
  2146.  
  2147.  
  2148. ;;; Parse-Tagbody  --  Internal
  2149. ;;;
  2150. ;;;    Return a list of the segments of a tagbody.  Each segment looks like
  2151. ;;; (<tag> <form>* (go <next tag>)).  That is, we break up the tagbody into
  2152. ;;; segments of non-tag statements, and explicitly represent the drop-through
  2153. ;;; with a GO.  The first segment has a dummy NIL tag, since it represents code
  2154. ;;; before the first tag.  The last segment (which may also be the first
  2155. ;;; segment) ends in NIL rather than a GO.
  2156. ;;;
  2157. (defun parse-tagbody (body)
  2158.   (declare (list body))
  2159.   (collect ((segments))
  2160.     (let ((current (cons nil body)))
  2161.       (loop
  2162.     (let ((tag-pos (position-if-not #'listp current :start 1)))
  2163.       (unless tag-pos
  2164.         (segments `(,@current nil))
  2165.         (return))
  2166.       (let ((tag (elt current tag-pos)))
  2167.         (when (assoc tag (segments))
  2168.           (compiler-error "Repeated tagbody tag: ~S." tag))
  2169.         (unless (or (symbolp tag) (integerp tag))
  2170.           (compiler-error "Illegal tagbody statement: ~S." tag))          
  2171.         (segments `(,@(subseq current 0 tag-pos) (go ,tag))))
  2172.       (setq current (nthcdr tag-pos current)))))
  2173.     (segments)))
  2174.   
  2175.  
  2176. ;;; Tagbody IR1 convert  --  Internal
  2177. ;;;
  2178. ;;;    Set up the cleanup, emitting the entry node.  Then make a block for each
  2179. ;;; tag, building up the tag list for LEXENV-TAGS as we go.  Finally, convert
  2180. ;;; each segment with the precomputed Start and Cont values.
  2181. ;;;
  2182. (def-ir1-translator tagbody ((&rest statements) start cont)
  2183.   "Tagbody {Tag | Statement}*
  2184.   Define tags for used with GO.  The Statements are evaluated in order
  2185.   (skipping Tags) and NIL is returned.  If a statement contains a GO to a
  2186.   defined Tag within the lexical scope of the form, then control is transferred
  2187.   to the next statement following that tag.  A Tag must an integer or a
  2188.   symbol.  A statement must be a list.  Other objects are illegal within the
  2189.   body."
  2190.   (continuation-starts-block cont)
  2191.   (let* ((dummy (make-continuation))
  2192.      (entry (make-entry))
  2193.      (segments (parse-tagbody statements))
  2194.      (cleanup (make-cleanup :kind :tagbody  :mess-up entry)))
  2195.     (push entry (lambda-entries (lexenv-lambda *lexical-environment*)))
  2196.     (setf (entry-cleanup entry) cleanup)
  2197.     (prev-link entry start)
  2198.     (use-continuation entry dummy)
  2199.     
  2200.     (collect ((tags)
  2201.           (starts)
  2202.           (conts))
  2203.       (starts dummy)
  2204.       (dolist (segment (rest segments))
  2205.     (let ((tag-cont (make-continuation)))
  2206.       (conts tag-cont)
  2207.       (starts tag-cont)
  2208.       (continuation-starts-block tag-cont)
  2209.       (tags (list (car segment) entry tag-cont))))
  2210.       (conts cont)
  2211.       
  2212.       (let ((*lexical-environment*
  2213.          (make-lexenv :cleanup cleanup :tags (tags))))
  2214.     (mapc #'(lambda (segment start cont)
  2215.           (ir1-convert-progn-body start cont (rest segment)))
  2216.           segments (starts) (conts))))))
  2217.  
  2218.  
  2219. ;;; Go IR1 convert  --  Internal
  2220. ;;;
  2221. ;;;    Emit an Exit node without any value.
  2222. ;;;
  2223. (def-ir1-translator go ((tag) start cont)
  2224.   "Go Tag
  2225.   Transfer control to the named Tag in the lexically enclosing TAGBODY.  This
  2226.   is constrained to be used only within the dynamic extent of the TAGBODY."
  2227.   (continuation-starts-block cont)
  2228.   (let* ((found (or (lexenv-find tag tags)
  2229.             (compiler-error "Go to nonexistent tag: ~S." tag)))
  2230.      (entry (first found))
  2231.      (exit (make-exit :entry entry)))
  2232.     (push exit (entry-exits entry))
  2233.     (prev-link exit start)
  2234.     (use-continuation exit (second found))))
  2235.  
  2236.  
  2237. ;;;; Translators for compiler-magic special forms:
  2238.  
  2239. (def-ir1-translator compiler-let ((bindings &rest body) start cont)
  2240.   (collect ((vars)
  2241.         (values))
  2242.     (dolist (bind bindings)
  2243.       (typecase bind
  2244.     (symbol
  2245.      (vars bind)
  2246.      (values nil))
  2247.     (list
  2248.      (unless (= (length bind) 2)
  2249.        (compiler-error "Bad compiler-let binding spec: ~S." bind))
  2250.      (vars (first bind))
  2251.      (values (eval (second bind))))
  2252.     (t
  2253.      (compiler-error "Bad compiler-let binding spec: ~S." bind))))
  2254.     (progv (vars) (values)
  2255.       (ir1-convert-progn-body start cont body))))
  2256.  
  2257.  
  2258. ;;; This flag is used by Eval-When to keep track of when code has already been
  2259. ;;; evaluated so that it can avoid multiple evaluation of nested Eval-When
  2260. ;;; (Compile)s.
  2261. ;;;
  2262. (proclaim '(special lisp::*already-evaled-this*))
  2263.  
  2264. ;;; DO-EVAL-WHEN-STUFF  --  Interface
  2265. ;;;
  2266. ;;;    Do stuff to do an EVAL-WHEN.  This is split off from the IR1 convert
  2267. ;;; method so that it can be shared by the special-case top-level form
  2268. ;;; processing code.  We play with the dynamic environment and eval stuff, then
  2269. ;;; call Fun with a list of forms to be processed at load time.
  2270. ;;;
  2271. ;;; Note: the EVAL situation is always ignored: this is conceptually a
  2272. ;;; compile-only implementation.
  2273. ;;;
  2274. ;;; We have to interact with the interpreter to ensure that the forms get
  2275. ;;; eval'ed exactly once.  We bind *already-evaled-this* to true to inhibit
  2276. ;;; evaluation of any enclosed EVAL-WHENs, either by IR1 conversion done by
  2277. ;;; EVAL, or by conversion of the body for load-time processing.  If
  2278. ;;; *already-evaled-this* is true then we *do not* eval since some enclosing
  2279. ;;; eval-when already did.
  2280. ;;;
  2281. ;;;    We know we are eval'ing for load since we wouldn't get called otherwise.
  2282. ;;; If LOAD is a situation we call Fun on body. If we aren't evaluating for
  2283. ;;; load, then we call Fun on NIL for the result of the EVAL-WHEN.
  2284. ;;;
  2285. (defun do-eval-when-stuff (situations body fun)
  2286.   (when (or (not (listp situations))
  2287.         (set-difference situations '(compile load eval)))
  2288.     (compiler-error "Bad Eval-When situation list: ~S." situations))
  2289.  
  2290.   (let* ((do-eval (and (member 'compile situations)
  2291.                (not lisp::*already-evaled-this*)))
  2292.      (lisp::*already-evaled-this* t))
  2293.     (when do-eval
  2294.       (eval `(progn ,@body)))
  2295.     (if (member 'load situations)
  2296.     (funcall fun body)
  2297.     (funcall fun '(nil)))))
  2298.  
  2299.   
  2300. (def-ir1-translator eval-when ((situations &rest body) start cont)
  2301.   "EVAL-WHEN (Situation*) Form*
  2302.   Evaluate the Forms in the specified Situations, any of COMPILE, LOAD, EVAL.
  2303.   This is conceptually a compile-only implementation, so EVAL is a no-op."
  2304.   (do-eval-when-stuff situations body
  2305.               #'(lambda (forms)
  2306.               (ir1-convert-progn-body start cont forms))))
  2307.  
  2308.  
  2309. ;;; DO-MACROLET-STUFF  --  Interface
  2310. ;;;
  2311. ;;;    Like DO-EVAL-WHEN-STUFF, only do a macrolet.  Fun is not passed any
  2312. ;;; arguments.
  2313. ;;;
  2314. (defun do-macrolet-stuff (definitions fun)
  2315.   (declare (list definitions) (type function fun))
  2316.   (let ((whole (gensym))
  2317.     (environment (gensym)))
  2318.     (collect ((new-fenv))
  2319.       (dolist (def definitions)
  2320.     (let ((name (first def))
  2321.           (arglist (second def))
  2322.           (body (cddr def)))
  2323.       (multiple-value-bind
  2324.           (body local-decs)
  2325.           (lisp::parse-defmacro arglist whole body name 'macrolet
  2326.                     :environment environment)
  2327.         (unless (symbolp name)
  2328.           (compiler-error "Macro name ~S is not a symbol." name))
  2329.         (when (< (length def) 3)
  2330.           (compiler-error
  2331.            "Local macro ~S is too short to be a legal definition." name))
  2332.         (new-fenv `(,(first def) macro .
  2333.             ,(coerce `(lambda (,whole ,environment)
  2334.                     ,@local-decs (block ,name ,body))
  2335.                  'function))))))
  2336.  
  2337.       (let ((*lexical-environment* (make-lexenv :functions (new-fenv))))
  2338.     (funcall fun))))
  2339.  
  2340.   (undefined-value))
  2341.  
  2342.  
  2343. (def-ir1-translator macrolet ((definitions &rest body) start cont)
  2344.   "MACROLET ({(Name Lambda-List Form*)}*) Body-Form*
  2345.   Evaluate the Body-Forms in an environment with the specified local macros
  2346.   defined.  Name is the local macro name, Lambda-List is the DEFMACRO style
  2347.   destructuring lambda list, and the Forms evaluate to the expansion.  The
  2348.   Forms are evaluated in the null environment."
  2349.   (do-macrolet-stuff definitions
  2350.              #'(lambda ()
  2351.              (ir1-convert-progn-body start cont body))))
  2352.  
  2353.  
  2354. ;;; Not really a special form, but...
  2355. ;;;
  2356. (def-ir1-translator declare ((&rest stuff) start cont)
  2357.   (declare (ignore stuff))
  2358.   start cont; Ignore hack
  2359.   (compiler-error "Misplaced declaration."))
  2360.  
  2361.  
  2362. ;;; COMPILER-OPTION-BIND
  2363. ;;; 
  2364. (def-ir1-translator compiler-option-bind ((bindings &body body) start cont)
  2365.   "Compiler-Option-Bind ({(Name Value-Form)}*) Body-Form*
  2366.    Establish the specified compiler options for the (lexical) duration of
  2367.    the body.  The Value-Forms are evaluated at compile time."
  2368.   (let ((*lexical-environment*
  2369.      (make-lexenv :options
  2370.               (mapcar #'(lambda (binding)
  2371.                   (unless (and (listp binding)
  2372.                            (cdr binding)
  2373.                            (listp (cdr binding))
  2374.                            (null (cddr binding)))
  2375.                     (compiler-error "Bogus binding for ~
  2376.                              COMPILER-OPTION-BIND: ~S"
  2377.                             binding))
  2378.                   (cons (car binding)
  2379.                     (eval (cadr binding))))
  2380.                   bindings))))
  2381.     (ir1-convert-progn-body start cont body)))
  2382.  
  2383.  
  2384. ;;;; %Primitive:
  2385. ;;;
  2386. ;;;    Uses of %primitive are either expanded into Lisp code or turned into a
  2387. ;;; funny function.
  2388. ;;;
  2389.  
  2390. ;;; Eval-Info-Args  --  Internal
  2391. ;;;
  2392. ;;;    Carefully evaluate a list of forms, returning a list of the results.
  2393. ;;;
  2394. (defun eval-info-args (args)
  2395.   (declare (list args))
  2396.   (handler-case (mapcar #'eval args)
  2397.     (error (condition)
  2398.       (compiler-error "Lisp error during evaluation of info args:~%~A"
  2399.               condition))))
  2400.  
  2401. ;;; A hashtable that translates from primitive names to translation functions.
  2402. ;;;
  2403. (defvar *primitive-translators* (make-hash-table :test #'eq))
  2404.  
  2405. ;;; IR1-Convert-%Primitive  --  Internal
  2406. ;;;
  2407. ;;;    If there is a primitive translator, then we expand the call.  Otherwise,
  2408. ;;; we convert to the %%Primitive funny function.  The first argument is the
  2409. ;;; template, the second is a list of the results of any codegen-info args, and
  2410. ;;; the remaining arguments are the runtime arguments.
  2411. ;;;
  2412. ;;;    We do a bunch of error checking now so that we don't bomb out with a
  2413. ;;; fatal error during IR2 conversion.
  2414. ;;;
  2415. (def-ir1-translator system:%primitive ((&whole form name &rest args)
  2416.                        start cont)
  2417.   
  2418.   (unless (symbolp name)
  2419.     (compiler-error "%Primitive name is not a symbol: ~S." name))
  2420.  
  2421.   (let* ((name (intern (symbol-name name)
  2422.                (or (find-package "OLD-C")
  2423.                (find-package "C"))))
  2424.      (translator (gethash name *primitive-translators*)))
  2425.     (if translator
  2426.     (ir1-convert start cont (funcall translator (cdr form)))
  2427.     (let* ((template (or (gethash name (backend-template-names *backend*))
  2428.                  (compiler-error "Undefined primitive name: ~A."
  2429.                          name)))
  2430.            (required (length (template-arg-types template)))
  2431.            (info (template-info-arg-count template))
  2432.            (min (+ required info))
  2433.            (nargs (length args)))
  2434.       (if (template-more-args-type template)
  2435.           (when (< nargs min)
  2436.         (compiler-error "Primitive called with ~R argument~:P, ~
  2437.                          but wants at least ~R."
  2438.                 nargs min))
  2439.           (unless (= nargs min)
  2440.         (compiler-error "Primitive called with ~R argument~:P, ~
  2441.                  but wants exactly ~R."
  2442.                 nargs min)))
  2443.  
  2444.       (when (eq (template-result-types template) :conditional)
  2445.         (compiler-error "%Primitive used with a conditional template."))
  2446.  
  2447.       (when (template-more-results-type template)
  2448.         (compiler-error
  2449.          "%Primitive used with an unknown values template."))
  2450.       
  2451.       (ir1-convert start cont
  2452.               `(%%primitive ',template
  2453.                     ',(eval-info-args
  2454.                        (subseq args required min))
  2455.                     ,@(subseq args 0 required)
  2456.                     ,@(subseq args min)))))))
  2457.  
  2458.  
  2459. ;;;; Quote and Function:
  2460.  
  2461. (def-ir1-translator quote ((thing) start cont)
  2462.   "QUOTE Value
  2463.   Return Value without evaluating it."
  2464.   (reference-constant start cont thing))
  2465.  
  2466.  
  2467. (def-ir1-translator function ((thing) start cont)
  2468.   "FUNCTION Name
  2469.   Return the lexically apparent definition of the function Name.  Name may also
  2470.   be a lambda."
  2471.   (if (and (consp thing) (eq (car thing) 'lambda))
  2472.       (reference-leaf start cont (ir1-convert-lambda thing nil 'function) nil)
  2473.       (multiple-value-bind (var inlinep)
  2474.                (find-lexically-apparent-function
  2475.                 thing "as the argument to FUNCTION")
  2476.     (reference-leaf start cont var inlinep))))
  2477.  
  2478.  
  2479. ;;;; Magic functions:
  2480. ;;;
  2481. ;;;    Various global functions must be treated magically in IR1 conversion.
  2482. ;;; If a function is always magical, then we just define an IR1-Convert method
  2483. ;;; for it.  If the magic is effectively a form of inline expansion, then we
  2484. ;;; define a source transform which transforms to an internal thing which we
  2485. ;;; pretend is a special form.
  2486. ;;;
  2487. ;;; %Funcall is used by people who want the call to be open-coded regardless of
  2488. ;;; user policy settings.
  2489. ;;;
  2490.  
  2491. (def-source-transform funcall (function &rest args)
  2492.   `(%funcall ,function ,@args))
  2493.  
  2494. (def-ir1-translator %funcall ((function &rest args) start cont)
  2495.   (let ((fun-cont (make-continuation)))
  2496.     (ir1-convert start fun-cont function)
  2497.     (ir1-convert-combination-args fun-cont cont args)))
  2498.  
  2499.  
  2500. ;;;; Symbol macros:
  2501.  
  2502. (def-ir1-translator symbol-macrolet ((specs &body (body decls)) start cont)
  2503.   "SYMBOL-MACROLET {(Name Expansion)}* Decl* Form*
  2504.   Define the Names as symbol macros with the given Expansions.  Within the
  2505.   body, references to a Name will effectively be replaced with the Expansion."
  2506.   (collect ((res))
  2507.     (dolist (spec specs)
  2508.       (unless (= (length spec) 2)
  2509.     (compiler-error "Malformed symbol macro binding: ~S." spec))
  2510.       (let ((name (first spec))
  2511.         (def (second spec)))
  2512.     (unless (symbolp name)
  2513.       (compiler-error "Symbol macro name is not a symbol: ~S." name))
  2514.     (when (assoc name (res))
  2515.       (compiler-warning "Repeated name in SYMBOL-MACROLET: ~S." name))
  2516.     (res `(,name . (MACRO . ,def)))))
  2517.  
  2518.     (let* ((*lexical-environment* (make-lexenv :variables (res)))
  2519.        (*lexical-environment* (process-declarations decls (res) nil cont)))
  2520.       (ir1-convert-progn-body start cont body))))
  2521.  
  2522.  
  2523. ;;;; Proclaim:
  2524. ;;;
  2525. ;;;    Proclaim changes the global environment, so we must special-case it if
  2526. ;;; we are to keep the information in the *FREE-xxx* variables up to date.
  2527. ;;; When there is a var structure we disown it by replacing it with an updated
  2528. ;;; copy.  Uses of the variable which were translated before the PROCLAIM will
  2529. ;;; get the old version, while subsequent references will get the updated
  2530. ;;; information. 
  2531.  
  2532.  
  2533. ;;; Get-Old-Vars  --  Internal
  2534. ;;;
  2535. ;;;    Look up some symbols in *free-variables*, returning the var structures
  2536. ;;; for any which exist.  If any of the names aren't symbols, we complain.
  2537. ;;;
  2538. (proclaim '(function get-old-vars (list) list))
  2539. (defun get-old-vars (names)
  2540.   (collect ((vars))
  2541.     (dolist (name names (vars))
  2542.       (unless (symbolp name)
  2543.     (compiler-error "Name is not a symbol: ~S." name))
  2544.       (let ((old (gethash name *free-variables*)))
  2545.     (when old (vars old))))))
  2546.  
  2547.  
  2548. ;;; Process-Type-Proclamation  --  Internal
  2549. ;;;
  2550. ;;;    Replace each old var entry with one having the new type.  If the new
  2551. ;;; type doesn't intersect with the old type, give a warning.  
  2552. ;;;
  2553. ;;;    We also check that the old type of each variable intersects with the new
  2554. ;;; one, giving a warning if not.  This isn't as serious as conflicting local
  2555. ;;; declarations, since we assume a redefinition semantics rather than an
  2556. ;;; intersection semantics.
  2557. ;;;
  2558. (proclaim '(function process-type-proclamation (t list) void))
  2559. (defun process-type-proclamation (spec names)
  2560.   (let ((type (specifier-type spec)))
  2561.     (unless (policy nil (= brevity 3))
  2562.       (dolist (name names)
  2563.     (let ((old-type (info variable type name)))
  2564.       (unless (types-intersect type old-type)
  2565.         (compiler-warning
  2566.          "New proclaimed type ~S for ~S conflicts with old type ~S."
  2567.          (type-specifier type) name (type-specifier old-type))))))
  2568.  
  2569.     (dolist (var (get-old-vars names))
  2570.       (let ((new (etypecase var
  2571.            (global-var (copy-global-var var))
  2572.            (constant (copy-constant var)))))
  2573.     (setf (leaf-type new) type)
  2574.     (setf (leaf-where-from new) :declared)
  2575.     (setf (gethash (leaf-name var) *free-variables*) new)))))
  2576.  
  2577.  
  2578.  
  2579. ;;; Process-1-Ftype-Proclamation  --  Internal
  2580. ;;;
  2581. ;;; Update function type info cached in *free-functions*.  If:
  2582. ;;; -- there is a GLOBAL-VAR, then just update the type and remove the name
  2583. ;;;    from the list of undefined functions.  Someday we should check for
  2584. ;;;    incompatible redeclaration.
  2585. ;;; -- there is a FUNCTIONAL, then apply the type assertion to that function.
  2586. ;;;    This will only happen during block compilation.
  2587. ;;;
  2588. (defun process-1-ftype-proclamation (name type)
  2589.   (declare (type function-type type))
  2590.   (let ((var (gethash (define-function-name name) *free-functions*)))
  2591.     (etypecase var
  2592.       (null)
  2593.       (slot-accessor)
  2594.       (global-var
  2595.        (let ((new (copy-global-var var))
  2596.          (name (leaf-name var)))
  2597.      (setf (leaf-type new) type)
  2598.      (setf (leaf-where-from new) :declared)
  2599.      (setf (gethash name *free-functions*) new)))
  2600.       (functional
  2601.        (assert-definition-type var type :warning-function #'compiler-note
  2602.                    :where "this declaration"))))
  2603.  
  2604.   (undefined-value))
  2605.  
  2606.  
  2607. ;;; Process-Ftype-Proclamation  --  Internal
  2608. ;;;
  2609. (proclaim '(function process-ftype-proclamation (t list) void))
  2610. (defun process-ftype-proclamation (spec names)
  2611.   (let ((type (specifier-type spec)))
  2612.     (unless (csubtypep type (specifier-type 'function))
  2613.       (compiler-error
  2614.        "Declared functional type is not a function type: ~S." spec))
  2615.     (dolist (name names)
  2616.       (process-1-ftype-proclamation name type))))
  2617.  
  2618.  
  2619. (def-ir1-translator proclaim ((what) start cont :kind :function)
  2620.   (if (constantp what)
  2621.       (let ((form (eval what)))
  2622.     (unless (consp form)
  2623.       (compiler-error "Malformed PROCLAIM spec: ~S." form))
  2624.     
  2625.     (let ((name (first form))
  2626.           (args (rest form))
  2627.           (ignore nil))
  2628.       (case (first form)
  2629.         (special
  2630.          (dolist (old (get-old-vars (rest form)))
  2631.            (when (or (constant-p old)
  2632.              (eq (global-var-kind old) :constant))
  2633.          (compiler-error
  2634.           "Attempt to proclaim constant ~S to be special." name))
  2635.            
  2636.            (ecase (global-var-kind old)
  2637.          (:special)
  2638.          (:global
  2639.           (let ((new (copy-global-var old)))
  2640.             (setf (global-var-kind new) :special)
  2641.             (setf (gethash name *free-variables*) new))))))
  2642.         (type
  2643.          (when (endp args)
  2644.            (compiler-error "Malformed TYPE proclamation: ~S." form))
  2645.          (process-type-proclamation (first args) (rest args)))
  2646.         (function
  2647.          (when (endp args)
  2648.            (compiler-error "Malformed FUNCTION proclamation: ~S." form))
  2649.          (process-ftype-proclamation `(function . ,(rest args))
  2650.                      (list (first args))))
  2651.         (ftype
  2652.          (when (endp args)
  2653.            (compiler-error "Malformed FTYPE proclamation: ~S." form))
  2654.          (process-ftype-proclamation (first args) (rest args)))
  2655.         ;;
  2656.         ;; No non-global state to be updated.
  2657.         ((inline notinline maybe-inline optimize optimize-interface
  2658.              declaration freeze-type constant-function))
  2659.         ;;
  2660.         ;; Totally ignore these operations at non-top-level.
  2661.         ((start-block end-block)
  2662.          (setq ignore t))
  2663.         (t
  2664.          (cond ((member name type-specifier-symbols)
  2665.             (process-type-proclamation name args))
  2666.            ((info declaration recognized name)
  2667.             (setq ignore t))
  2668.            (t
  2669.             (setq ignore t)
  2670.             (compiler-warning "Unrecognized proclamation: ~S."
  2671.                       form)))))
  2672.       
  2673.       (unless ignore
  2674.         (funcall #'%proclaim form))
  2675.       (if ignore
  2676.           (ir1-convert start cont nil)
  2677.           (ir1-convert start cont `(%proclaim ,what)))))
  2678.       (ir1-convert start cont `(%proclaim ,what))))
  2679.  
  2680.  
  2681. ;;; %Compiler-Defstruct IR1 Convert  --  Internal
  2682. ;;;
  2683. ;;;    This is a frob that DEFMACRO expands into to establish the compiler
  2684. ;;; semantics.  %%COMPILER-DEFSTRUCT does most of the work, we just clear all
  2685. ;;; of the functions out of *FREE-FUNCTIONS* to keep things in synch.
  2686. ;;;
  2687. (def-ir1-translator %compiler-defstruct ((info) start cont :kind :function)
  2688.   (let* ((info (eval info)))
  2689.     (funcall #'%%compiler-defstruct info)
  2690.     (dolist (slot (dd-slots info))
  2691.       (let ((fun (dsd-accessor slot)))
  2692.     (remhash fun *free-functions*)
  2693.     (unless (dsd-read-only slot)
  2694.       (remhash `(setf ,fun) *free-functions*))))
  2695.     (remhash (dd-predicate info) *free-functions*)
  2696.     (remhash (dd-copier info) *free-functions*)
  2697.     (ir1-convert start cont `(%%compiler-defstruct ',info))))
  2698.  
  2699.  
  2700. ;;;; Let and Let*:
  2701. ;;;
  2702. ;;;    Let and Let* can't be implemented as macros due to the fact that
  2703. ;;; any pervasive declarations also affect the evaluation of the arguments.
  2704.  
  2705. ;;; Extract-Let-Variables  --  Internal
  2706. ;;;
  2707. ;;;    Given a list of binding specifiers in the style of Let, return:
  2708. ;;;  1] The list of var structures for the variables bound.
  2709. ;;;  2] The initial value form for each variable.
  2710. ;;;
  2711. ;;; The variable names are checked for legality and globally special variables
  2712. ;;; are marked as such.  Context is the name of the form, for error reporting
  2713. ;;; purposes.
  2714. ;;;
  2715. (proclaim '(function extract-let-variables (list symbol)
  2716.              (values list list list)))
  2717. (defun extract-let-variables (bindings context)
  2718.   (collect ((vars)
  2719.         (vals)
  2720.         (names))
  2721.     (flet ((get-var (name)
  2722.          (varify-lambda-arg name
  2723.                 (if (eq context 'let*)
  2724.                     nil
  2725.                     (names)))))
  2726.       (dolist (spec bindings)
  2727.     (cond ((atom spec)
  2728.            (let ((var (get-var spec)))
  2729.          (vars var)
  2730.          (names (cons spec var)) 
  2731.          (vals nil)))
  2732.           (t
  2733.            (unless (<= 1 (length spec) 2)
  2734.          (compiler-error "Malformed ~S binding spec: ~S."
  2735.                  context spec))
  2736.            (let* ((name (first spec))
  2737.               (var (get-var name)))
  2738.          (vars var)
  2739.          (names name)
  2740.          (vals (second spec)))))))
  2741.  
  2742.     (values (vars) (vals) (names))))
  2743.  
  2744.  
  2745. (def-ir1-translator let ((bindings &body (body decls))
  2746.              start cont)
  2747.   "LET ({(Var [Value]) | Var}*) Declaration* Form*
  2748.   During evaluation of the Forms, Bind the Vars to the result of evaluating the
  2749.   Value forms.  The variables are bound in parallel after all of the Values are
  2750.   evaluated."
  2751.   (multiple-value-bind (vars values)
  2752.                (extract-let-variables bindings 'let)
  2753.     (let* ((*lexical-environment* (process-declarations decls vars nil cont))
  2754.        (fun-cont (make-continuation))
  2755.        (fun (ir1-convert-lambda-body body vars)))
  2756.       (reference-leaf start fun-cont fun nil)
  2757.       (ir1-convert-combination-args fun-cont cont values))))
  2758.  
  2759.  
  2760. (def-ir1-translator let* ((bindings &body (body decls))
  2761.               start cont)
  2762.   "LET* ({(Var [Value]) | Var}*) Declaration* Form*
  2763.   Similar to LET, but the variables are bound sequentially, allowing each Value
  2764.   form to reference any of the previous Vars."
  2765.   (multiple-value-bind (vars values)
  2766.                (extract-let-variables bindings 'let*)
  2767.     (let ((*lexical-environment* (process-declarations decls vars nil cont)))
  2768.       (ir1-convert-aux-bindings start cont body vars values nil))))
  2769.  
  2770.  
  2771. ;;;; Flet and Labels:
  2772.  
  2773. ;;; Extract-Flet-Variables  --  Internal
  2774. ;;;
  2775. ;;;    Given a list of local function specifications in the style of Flet,
  2776. ;;; return lists of the function names and of the lambdas which are their
  2777. ;;; definitions.
  2778. ;;;
  2779. ;;; The function names are checked for legality.  Context is the name of the
  2780. ;;; form, for error reporting.
  2781. ;;;
  2782. (proclaim '(function extract-flet-variables (list symbol) (values list list)))
  2783. (defun extract-flet-variables (definitions context)
  2784.   (collect ((names)
  2785.         (defs))
  2786.     (dolist (def definitions)
  2787.       (when (or (atom def) (< (length def) 2))
  2788.     (compiler-error "Malformed ~S definition spec: ~S." context def))
  2789.       
  2790.       (let ((name (check-function-name (first def))))
  2791.     (names name)
  2792.     (multiple-value-bind
  2793.         (body decls)
  2794.         (system:parse-body (cddr def) *lexical-environment* t)
  2795.       (defs `(lambda ,(second def)
  2796.            ,@decls
  2797.            (block ,(if (consp name) (second name) name)
  2798.              . ,body))))))
  2799.     (values (names) (defs))))
  2800.  
  2801.  
  2802. (def-ir1-translator flet ((definitions &body (body decls))
  2803.               start cont)
  2804.   "FLET ({(Name Lambda-List Declaration* Form*)}*) Declaration* Body-Form*
  2805.   Evaluate the Body-Forms with some local function definitions.   The bindings
  2806.   do not enclose the definitions; any use of Name in the Forms will refer to
  2807.   the lexically apparent function definition in the enclosing environment."
  2808.   (multiple-value-bind (names defs)
  2809.                (extract-flet-variables definitions 'flet)
  2810.     (let* ((fvars (mapcar #'(lambda (n d)
  2811.                   (let ((res (ir1-convert-lambda d n 'flet)))
  2812.                 (setf (leaf-name res) n)
  2813.                 res))
  2814.               names defs))
  2815.        (*lexical-environment*
  2816.         (make-lexenv :default (process-declarations decls nil fvars cont)
  2817.              :functions (pairlis names fvars))))
  2818.       (ir1-convert-progn-body start cont body))))
  2819.  
  2820.  
  2821. ;;; For Labels, we have to create dummy function vars and add them to the
  2822. ;;; function namespace while converting the functions.  We then modify all the
  2823. ;;; references to these leaves so that they point to the real functional
  2824. ;;; leaves.  We also backpatch the FENV so that if the lexical environment is
  2825. ;;; used for inline expansion we will get the right functions.
  2826. ;;;
  2827. ;;; [### Perhaps not totally correct, since the declarations aren't processed
  2828. ;;; until after the function definitions.  This means that declarations for
  2829. ;;; local functions may not have their full effect on references within the
  2830. ;;; local functions.]
  2831. ;;;
  2832. (def-ir1-translator labels ((definitions &body (body decls)) start cont)
  2833.   "LABELS ({(Name Lambda-List Declaration* Form*)}*) Declaration* Body-Form*
  2834.   Evaluate the Body-Forms with some local function definitions.  The bindings
  2835.   enclose the new definitions, so the defined functions can call themselves or
  2836.   each other."
  2837.   (multiple-value-bind (names defs)
  2838.                (extract-flet-variables definitions 'labels)
  2839.     (let* ((new-fenv (loop for name in names
  2840.                collect (cons name (make-functional :name name))))
  2841.        (real-funs 
  2842.         (let ((*lexical-environment* (make-lexenv :functions new-fenv)))
  2843.           (mapcar #'(lambda (n d)
  2844.               (let ((res (ir1-convert-lambda d n 'labels)))
  2845.                 (setf (leaf-name res) n)
  2846.                 res))
  2847.               names defs))))
  2848.  
  2849.       (loop for real in real-funs and env in new-fenv do
  2850.     (let ((dum (cdr env)))
  2851.       (substitute-leaf real dum)
  2852.       (setf (cdr env) real)))
  2853.  
  2854.       (let ((*lexical-environment*
  2855.          (make-lexenv
  2856.           :default (process-declarations decls nil real-funs cont)
  2857.           :functions (pairlis names real-funs))))
  2858.     (ir1-convert-progn-body start cont body)))))
  2859.  
  2860.  
  2861. ;;;; THE
  2862.  
  2863. ;;; DO-THE-STUFF  --  Internal
  2864. ;;;
  2865. ;;;    Do stuff to recognize a THE or VALUES declaration.  Cont is the
  2866. ;;; continuation that the assertion applies to, Type is the type specifier and
  2867. ;;; Lexenv is the current lexical environment.  Name is the name of the
  2868. ;;; declaration we are doing, for use in error messages.
  2869. ;;;
  2870. ;;;    This is somewhat involved, since a type assertion may only be made on a
  2871. ;;; continuation, not on a node.  We can't just set the continuation asserted
  2872. ;;; type and let it go at that, since there may be paralell THE's for the same
  2873. ;;; continuation, i.e.:
  2874. ;;;     (if ...
  2875. ;;;         (the foo ...)
  2876. ;;;         (the bar ...))
  2877. ;;;
  2878. ;;; In this case, our representation can do no better than the union of these
  2879. ;;; assertions.  And if there is a branch with no assertion, we have nothing at
  2880. ;;; all.  We really need to recognize scoping, since we need to be able to
  2881. ;;; discern between parallel assertions (which we union) and nested ones (which
  2882. ;;; we intersect).
  2883. ;;;
  2884. ;;; We represent the scoping by throwing our innermost (intersected) assertion
  2885. ;;; on Cont into the TYPE-RESTRICTIONS.  As we go down, we intersect our
  2886. ;;; assertions together.  If Cont has no uses yet, we have not yet bottomed out
  2887. ;;; on the first COND branch; in this case we optimistically assume that this
  2888. ;;; type will be the one we end up with, and set the ASSERTED-TYPE to it.
  2889. ;;; We can never get better than the type that we have the first time we bottom
  2890. ;;; out.  Later THE's (or the absence thereof) can only weaken this result.
  2891. ;;;
  2892. ;;; We make this work by getting USE-CONTINUATION to do the unioning across
  2893. ;;; COND branches.  We can't do it here, since we don't know how many branches
  2894. ;;; there are going to be.
  2895. ;;;
  2896. (defun do-the-stuff (type cont lexenv name)
  2897.   (declare (type continuation cont) (type lexenv lexenv))
  2898.   (let* ((ctype (values-specifier-type type))
  2899.      (old-type (or (lexenv-find cont type-restrictions)
  2900.                *wild-type*))
  2901.      (intersects (values-types-intersect old-type ctype))
  2902.      (int (values-type-intersection old-type ctype))
  2903.      (new (if intersects int old-type)))
  2904.     (when (null (find-uses cont))
  2905.       (setf (continuation-asserted-type cont) new))
  2906.     (when (and (not intersects)
  2907.            (not (policy nil (= brevity 3))))
  2908.       (compiler-warning
  2909.        "Type ~S in ~S declaration conflicts with enclosing assertion:~%   ~S"
  2910.        (type-specifier ctype) name (type-specifier old-type)))
  2911.     (make-lexenv :type-restrictions `((,cont . ,new))
  2912.          :default lexenv)))
  2913.  
  2914.  
  2915. ;;; THE IR1 Convert  --  Internal
  2916. ;;;
  2917. (def-ir1-translator the ((type value) start cont)
  2918.   "THE Type Form
  2919.   Assert that Form evaluates to the specified type (which may be a VALUES
  2920.   type.)"
  2921.   (let ((*lexical-environment*
  2922.      (do-the-stuff type cont *lexical-environment* 'the)))
  2923.       (ir1-convert start cont value)))
  2924.  
  2925.  
  2926. ;;; Truly-The IR1 convert  --  Internal
  2927. ;;;
  2928. ;;;    Since the Continuation-Derived-Type is computed as the union of its
  2929. ;;; uses's types, setting it won't work.  Instead we must intersect the type
  2930. ;;; with the uses's Derived-Type.
  2931. ;;;
  2932. (def-ir1-translator truly-the ((type value) start cont)
  2933.   "Truly-The Type Value
  2934.   Like the THE special form, except that it believes whatever you tell it.  It
  2935.   will never generate a type check, but will cause a warning if the compiler
  2936.   can prove the assertion is wrong."
  2937.   (let ((type (values-specifier-type type))
  2938.     (old (find-uses cont)))
  2939.     (ir1-convert start cont value)
  2940.     (do-uses (use cont)
  2941.       (unless (member use old)
  2942.     (derive-node-type use type)))))
  2943.  
  2944.  
  2945. ;;;; Setq
  2946. ;;;
  2947. ;;;    If there is a definition in LEXENV-VARIABLES, just set that, otherwise
  2948. ;;; look at the global information.  If the name is for a constant, then error
  2949. ;;; out.
  2950.  
  2951. (def-ir1-translator setq ((&whole source &rest things) start cont)
  2952.   "SETQ {Var Value}*
  2953.   Set the variables to the values.  If more than one pair is supplied, the
  2954.   assignments are done sequentially.  If Var names a symbol macro, SETF the
  2955.   expansion."
  2956.   (let ((len (length things)))
  2957.     (when (oddp len)
  2958.       (compiler-error "Odd number of args to SETQ: ~S." source))
  2959.     (if (= len 2)
  2960.     (let* ((name (first things))
  2961.            (leaf (or (lexenv-find name variables)
  2962.              (find-free-variable name))))
  2963.       (etypecase leaf
  2964.         (leaf
  2965.          (when (or (constant-p leaf)
  2966.                (and (global-var-p leaf)
  2967.                 (eq (global-var-kind leaf) :constant)))
  2968.            (compiler-error "Attempt to set constant ~S." name))
  2969.          (when (and (lambda-var-p leaf)
  2970.             (lambda-var-ignorep leaf))
  2971.            (compiler-warning "Setting an ignored variable: ~S." name))
  2972.          (set-variable start cont leaf (second things)))
  2973.         (cons
  2974.          (assert (eq (car leaf) 'MACRO))
  2975.          (ir1-convert start cont `(setf ,(cdr leaf) ,(second things))))
  2976.         (heap-alien-info
  2977.          (ir1-convert start cont
  2978.               `(%set-heap-alien ',leaf ,(second things))))))
  2979.     (collect ((sets))
  2980.       (do ((thing things (cddr thing)))
  2981.           ((endp thing)
  2982.            (ir1-convert-progn-body start cont (sets)))
  2983.         (sets `(setq ,(first thing) ,(second thing))))))))
  2984.  
  2985. ;;;; Catch, Throw and Unwind-Protect:
  2986. ;;;
  2987.  
  2988. ;;; Throw  --  Public
  2989. ;;;
  2990. ;;;    Although throw could be a macro, it seems this would cause unnecessary
  2991. ;;; confusion.  We turn THROW into a multiple-value-call of a magical function,
  2992. ;;; since as as far as IR1 is concerned, it has no interesting properties other
  2993. ;;; than receiving multiple-values.
  2994. ;;;
  2995. (def-ir1-translator throw ((tag result) start cont)
  2996.   "Throw Tag Form
  2997.   Do a non-local exit, return the values of Form from the CATCH whose tag
  2998.   evaluates to the same thing as Tag."
  2999.   (ir1-convert start cont
  3000.            `(multiple-value-call #'%throw ,tag ,result)))
  3001.  
  3002.  
  3003. ;;; This is a special special form used to instantiate a cleanup as the current
  3004. ;;; cleanup within the body.  Kind is a the kind of cleanup to make, and
  3005. ;;; Mess-Up is a form that does the mess-up action.  We make the MESS-UP be the
  3006. ;;; USE of the Mess-Up form's continuation, and introduce the cleanup into the
  3007. ;;; lexical environment.  We back-patch the Entry-Cleanup for the current
  3008. ;;; cleanup to be the new cleanup, since this inner cleanup is the interesting
  3009. ;;; one.
  3010. ;;;
  3011. (def-ir1-translator %within-cleanup ((kind mess-up &body body) start cont)
  3012.   (let ((dummy (make-continuation))
  3013.     (dummy2 (make-continuation)))
  3014.     (ir1-convert start dummy mess-up)
  3015.     (let* ((mess-node (continuation-use dummy))
  3016.        (cleanup (make-cleanup :kind kind  :mess-up mess-node))
  3017.        (old-cup (lexenv-cleanup *lexical-environment*))
  3018.        (*lexical-environment* (make-lexenv :cleanup cleanup)))
  3019.       (setf (entry-cleanup (cleanup-mess-up old-cup)) cleanup)
  3020.       (ir1-convert dummy dummy2 '(%cleanup-point))
  3021.       (ir1-convert-progn-body dummy2 cont body))))
  3022.  
  3023.  
  3024. ;;; This is a special special form that makes an "escape function" which
  3025. ;;; returns unknown values from named block.  We convert the function, set its
  3026. ;;; kind to :Escape, and then reference it.  The :Escape kind indicates that
  3027. ;;; this function's purpose is to represent a non-local control transfer, and
  3028. ;;; that it might not actually have to be compiled.
  3029. ;;;
  3030. ;;; Note that environment analysis replaces references to escape functions
  3031. ;;; with references to the corresponding NLX-Info structure.
  3032. ;;;
  3033. (def-ir1-translator %escape-function ((tag) start cont)
  3034.   (let ((fun (ir1-convert-lambda
  3035.           `(lambda ()
  3036.          (return-from ,tag (%unknown-values))))))
  3037.     (setf (functional-kind fun) :escape)
  3038.     (reference-leaf start cont fun nil)))
  3039.  
  3040.  
  3041. ;;; Yet another special special form.  This one looks up a local function and
  3042. ;;; smashes it to a :Cleanup function, as well as referencing it.
  3043. ;;;
  3044. (def-ir1-translator %cleanup-function ((name) start cont)
  3045.   (let ((fun (lexenv-find name functions)))
  3046.     (assert (lambda-p fun))
  3047.     (setf (functional-kind fun) :cleanup)
  3048.     (reference-leaf start cont fun nil)))
  3049.  
  3050.  
  3051. ;;; Catch  --  Public
  3052. ;;;
  3053. ;;;    Catch could be a macro, but it's somewhat tasteless to expand into
  3054. ;;; implementation-dependent special forms.
  3055. ;;;
  3056. ;;;    We represent the possibility of the control transfer by making an
  3057. ;;; "escape function" that does a lexical exit, and instantiate the cleanup
  3058. ;;; using %within-cleanup.
  3059. ;;;
  3060. (def-ir1-translator catch ((tag &body body) start cont)
  3061.   "Catch Tag Form*
  3062.   Evaluates Tag and instantiates it as a catcher while the body forms are
  3063.   evaluated in an implicit PROGN.  If a THROW is done to Tag within the dynamic
  3064.   scope of the body, then control will be transferred to the end of the body
  3065.   and the thrown values will be returned."
  3066.   (ir1-convert
  3067.    start cont
  3068.    (let ((exit-block (gensym)))
  3069.      `(block ,exit-block
  3070.     (%within-cleanup
  3071.         :catch
  3072.         (%catch (%escape-function ,exit-block) ,tag)
  3073.       ,@body)))))
  3074.  
  3075.  
  3076. ;;; Unwind-Protect  --  Public
  3077. ;;;
  3078. ;;;    Unwind-Protect is similar to Catch, but more hairy.  We make the cleanup
  3079. ;;; forms into a local function so that they can be referenced both in the case
  3080. ;;; where we are unwound and in any local exits.  We use %Cleanup-Function on
  3081. ;;; this to indicate that reference by %Unwind-Protect isn't "real", and thus
  3082. ;;; doesn't cause creation of an XEP.
  3083. ;;;
  3084. (def-ir1-translator unwind-protect ((protected &body cleanup) start cont)
  3085.   "Unwind-Protect Protected Cleanup*
  3086.   Evaluate the form Protected, returning its values.  The cleanup forms are
  3087.   evaluated whenever the dynamic scope of the Protected form is exited (either
  3088.   due to normal completion or a non-local exit such as THROW)."
  3089.   (ir1-convert
  3090.    start cont
  3091.    (let ((cleanup-fun (gensym))
  3092.      (drop-thru-tag (gensym))
  3093.      (exit-tag (gensym))
  3094.      (next (gensym))
  3095.      (start (gensym))
  3096.      (count (gensym)))
  3097.      `(flet ((,cleanup-fun () ,@cleanup nil))
  3098.     (block ,drop-thru-tag
  3099.       (multiple-value-bind
  3100.           (,next ,start ,count)
  3101.           (block ,exit-tag
  3102.         (%within-cleanup
  3103.             :unwind-protect
  3104.             (%unwind-protect (%escape-function ,exit-tag)
  3105.                      (%cleanup-function ,cleanup-fun))
  3106.           (return-from ,drop-thru-tag ,protected)))
  3107.         (,cleanup-fun)
  3108.         (%continue-unwind ,next ,start ,count)))))))
  3109.  
  3110.  
  3111. ;;;; MV stuff.
  3112.  
  3113. ;;; If there are arguments, multiple-value-call turns into an MV-Combination.
  3114. ;;;
  3115. ;;; If there are no arguments, then we convert to a normal combination,
  3116. ;;; ensuring that a MV-Combination always has at least one argument.  This can
  3117. ;;; be regarded as an optimization, but it is more important for simplifying
  3118. ;;; compilation of MV-Combinations.
  3119. ;;;
  3120. (def-ir1-translator multiple-value-call ((fun &rest args) start cont)
  3121.   "MULTIPLE-VALUE-CALL Function Values-Form*
  3122.   Call Function, passing all the values of each Values-Form as arguments,
  3123.   values from the first Values-Form making up the first argument, etc."
  3124.   (let* ((fun-cont (make-continuation))
  3125.      (node (if args
  3126.            (make-mv-combination fun-cont)
  3127.            (make-combination fun-cont))))
  3128.     (ir1-convert start fun-cont fun)
  3129.     (setf (continuation-dest fun-cont) node)
  3130.     (assert-continuation-type fun-cont
  3131.                   (specifier-type '(or function symbol)))
  3132.     (collect ((arg-conts))
  3133.       (let ((this-start fun-cont))
  3134.     (dolist (arg args)
  3135.       (let ((this-cont (make-continuation node)))
  3136.         (ir1-convert this-start this-cont arg)
  3137.         (setq this-start this-cont)
  3138.         (arg-conts this-cont)))
  3139.     (prev-link node this-start)
  3140.     (use-continuation node cont)
  3141.     (setf (basic-combination-args node) (arg-conts))))))
  3142.  
  3143.  
  3144. ;;; IR1 convert Multiple-Value-Prog1  --  Internal
  3145. ;;;
  3146. ;;; Multiple-Value-Prog1 is represented implicitly in IR1 by having a the
  3147. ;;; result code use result continuation (CONT), but transfer control to the
  3148. ;;; evaluation of the body.  In other words, the result continuation isn't
  3149. ;;; Immediately-Used-P by the nodes that compute the result.
  3150. ;;;
  3151. ;;; In order to get the control flow right, we convert the result with a dummy
  3152. ;;; result continuation, then convert all the uses of the dummy to be uses of
  3153. ;;; CONT.  If a use is an Exit, then we also substitute CONT for the dummy in
  3154. ;;; the corresponding Entry node so that they are consistent.  Note that this
  3155. ;;; doesn't amount to changing the exit target, since the control destination
  3156. ;;; of an exit is determined by the block successor; we are just indicating the
  3157. ;;; continuation that the result is delivered to.
  3158. ;;;
  3159. ;;; We then convert the body, using another dummy continuation in its own block
  3160. ;;; as the result.  After we are done converting the body, we move all
  3161. ;;; predecessors of the dummy end block to CONT's block.
  3162. ;;;
  3163. ;;; Note that we both exploit and maintain the invariant that the CONT to an
  3164. ;;; IR1 convert method either has no block or starts the block that control
  3165. ;;; should transfer to after completion for the form.  Nested MV-Prog1's work
  3166. ;;; because during conversion of the result form, we use dummy continuation
  3167. ;;; whose block is the true control destination.
  3168. ;;;
  3169. (def-ir1-translator multiple-value-prog1 ((result &rest forms) start cont)
  3170.   "MULTIPLE-VALUE-PROG1 Values-Form Form*
  3171.   Evaluate Values-Form and then the Forms, but return all the values of
  3172.   Values-Form." 
  3173.   (continuation-starts-block cont)
  3174.   (let* ((dummy-result (make-continuation))
  3175.      (dummy-start (make-continuation))
  3176.      (cont-block (continuation-block cont)))
  3177.     (continuation-starts-block dummy-start)
  3178.     (ir1-convert start dummy-start result)
  3179.  
  3180.     (substitute-continuation-uses cont dummy-start)
  3181.  
  3182.     (continuation-starts-block dummy-result)
  3183.     (ir1-convert-progn-body dummy-start dummy-result forms)
  3184.     (let ((end-block (continuation-block dummy-result)))
  3185.       (dolist (pred (block-pred end-block))
  3186.     (unlink-blocks pred end-block)
  3187.     (link-blocks pred cont-block))
  3188.       (assert (not (continuation-dest dummy-result)))
  3189.       (delete-continuation dummy-result)
  3190.       (remove-from-dfo end-block))))
  3191.  
  3192.  
  3193.  
  3194. ;;;; Interface to defining macros:
  3195. ;;;
  3196. ;;;    DEFMACRO, DEFUN and DEFCONSTANT expand into calls to %DEFxxx functions
  3197. ;;; so that we get a chance to see what is going on.  We define IR1 translators
  3198. ;;; for these functions which look at the definition and then generate a call
  3199. ;;; to the %%DEFxxx function. 
  3200. ;;;
  3201.  
  3202.  
  3203. ;;; REVERT-SOURCE-PATH  --  Internal
  3204. ;;;
  3205. ;;;    Return a new source path with any stuff intervening between the current
  3206. ;;; path and the first form beginning with Name stripped off.  This is used to
  3207. ;;; hide the guts of DEFmumble macros to prevent annoying error messages.
  3208. ;;; 
  3209. (defun revert-source-path (name)
  3210.   (do ((path *current-path* (cdr path)))
  3211.       ((null path) *current-path*)
  3212.     (let ((first (first path)))
  3213.       (when (or (eq first name)
  3214.         (eq first 'original-source-start))
  3215.     (return path)))))
  3216.  
  3217.  
  3218. ;;; Warn about incompatible or illegal definitions and add the macro to the
  3219. ;;; compiler environment.  
  3220. ;;;
  3221. ;;; Someday we could check for macro arguments being incompatibly redefined.
  3222. ;;; Doing this right will involve finding the old macro lambda-list and
  3223. ;;; comparing it with the new one.  We don't want to use min-args and max-args
  3224. ;;; since they don't completely describe the macro's syntax.
  3225. ;;;
  3226. (def-ir1-translator %defmacro ((name def lambda-list doc) start cont
  3227.                    :kind :function)
  3228.   (let ((name (eval name))
  3229.     (def (second def))) ; Don't want to make a function just yet...
  3230.     (unless (symbolp name)
  3231.       (compiler-error "Macro name is not a symbol: ~S." name))
  3232.  
  3233.     (ecase (info function kind name)
  3234.       ((nil))
  3235.       (:function
  3236.        (remhash name *free-functions*)
  3237.        (undefine-function-name name)
  3238.        (compiler-warning
  3239.     "Defining ~S to be a macro when it was ~(~A~) to be a function."
  3240.     name (info function where-from name)))
  3241.       (:macro)
  3242.       (:special-form
  3243.        (compiler-error "Attempt to redefine special form ~S as a macro."
  3244.                name)))
  3245.  
  3246.     (setf (info function kind name) :macro)
  3247.     (setf (info function where-from name) :defined)
  3248.  
  3249.     (when *compile-time-define-macros*
  3250.       (setf (info function macro-function name)
  3251.         (coerce def 'function)))
  3252.  
  3253.     (let* ((*current-path* (revert-source-path 'defmacro))
  3254.        (fun (ir1-convert-lambda def name 'defmacro)))
  3255.       (setf (leaf-name fun)
  3256.         (concatenate 'string "DEFMACRO " (symbol-name name)))
  3257.       (setf (functional-arg-documentation fun) (eval lambda-list))
  3258.  
  3259.       (ir1-convert start cont `(%%defmacro ',name ,fun ,doc)))
  3260.  
  3261.     (when *compile-print*
  3262.       (compiler-mumble "Converted ~S.~%" name))))
  3263.  
  3264.  
  3265. (def-ir1-translator %define-compiler-macro ((name def lambda-list doc)
  3266.                         start cont
  3267.                         :kind :function)
  3268.   (let ((name (eval name))
  3269.     (def (second def))) ; Don't want to make a function just yet...
  3270.  
  3271.     (when (eq (info function kind name) :special-form)
  3272.       (compiler-error "Attempt to define a compiler-macro for special form ~S."
  3273.               name))
  3274.  
  3275.     (when *compile-time-define-macros*
  3276.       (setf (info function compiler-macro-function name)
  3277.         (coerce def 'function)))
  3278.  
  3279.     (let* ((*current-path* (revert-source-path 'define-compiler-macro))
  3280.        (fun (ir1-convert-lambda def name 'define-compiler-macro)))
  3281.       (setf (leaf-name fun)
  3282.         (let ((*print-case* :upcase))
  3283.           (format nil "DEFINE-COMPILER-MACRO ~S" name)))
  3284.       (setf (functional-arg-documentation fun) (eval lambda-list))
  3285.  
  3286.       (ir1-convert start cont `(%%define-compiler-macro ',name ,fun ,doc)))
  3287.  
  3288.     (when *compile-print*
  3289.       (compiler-mumble "Converted ~S.~%" name))))
  3290.  
  3291.  
  3292. ;;; %DEFUN IR1 convert  --  Internal
  3293. ;;;
  3294. ;;; Convert the definition and install it in the global environment with a
  3295. ;;; LABELS-like effect.  If the lexical environment is not null, then we only
  3296. ;;; install the definition during the processing of this DEFUN, ensuring that
  3297. ;;; the function cannot be called outside of the correct environment.  If the
  3298. ;;; function is gloablly NOTINLINE, then that inhibits even local substitution.
  3299. ;;; Also, emit top-level code to install the definition.
  3300. ;;;
  3301. ;;; This is one of the major places where the semantics of block compilation is
  3302. ;;; handled.  Substituion for global names is totally inhibited if
  3303. ;;; *block-compile* it NIL.  And if *block-compile* us true and entry points
  3304. ;;; are specified, then we don't install global definitions for non-entry
  3305. ;;; functions (effectively turning them into local lexical functions.)
  3306. ;;;
  3307. (def-ir1-translator %defun ((name def doc source) start cont
  3308.                 :kind :function)
  3309.   (declare (ignore source))
  3310.   (let* ((name (define-function-name (eval name)))
  3311.      (expansion
  3312.       (if (and (member (info function inlinep name)
  3313.                '(:inline :maybe-inline))
  3314.            (in-null-environment))
  3315.           (cadr def) nil))
  3316.      (null-fenv-p (in-null-environment t))
  3317.      (*current-path* (revert-source-path 'defun))
  3318.      (save-type (info function type name))
  3319.      (where-from (info function where-from name))
  3320.      (function-info (info function info name)))
  3321.     (setf (info function inline-expansion name) expansion)
  3322.     ;;
  3323.     ;; If *FREE-FUNCTIONS* has a previous DEFUN for this name, then blow it
  3324.     ;; away.  If it is a global defined variable, then clear the type.
  3325.     ;; bogus information back in.
  3326.     (let ((old (gethash name *free-functions*)))
  3327.       (cond ((functional-p old)
  3328.          (remhash name *free-functions*))
  3329.         (old
  3330.          (when (eq (leaf-where-from old) :defined)
  3331.            (setf (leaf-type old) (specifier-type 'function))))))
  3332.     ;;
  3333.     ;; If a defined variable, clear the recorded function type so that we don't
  3334.     ;; pull possibly bogus information back in.
  3335.     (when (eq where-from :defined)
  3336.       (setf (info function type name) (specifier-type 'function)))
  3337.     ;;
  3338.     ;; If not in a null environment, discard any forward references to this
  3339.     ;; function.
  3340.     (unless null-fenv-p (remhash name *free-functions*))
  3341.     (let ((fun (ir1-convert-lambda (cadr def) name 'defun))
  3342.       (old (gethash name *free-functions*)))
  3343.       (setf (leaf-name fun) name)
  3344.       ;;
  3345.       ;; If definitely not an interpreter stub, then substitute for any
  3346.       ;; old references that aren't :NOTINLINE. 
  3347.       (unless (or (eq (info function inlinep name) :notinline)
  3348.           (not *block-compile*)
  3349.           (and function-info
  3350.                (or (function-info-transforms function-info)
  3351.                (function-info-templates function-info)
  3352.                (function-info-ir2-convert function-info))))
  3353.     (setf (gethash name *free-functions*) fun)
  3354.     (when old
  3355.       (substitute-leaf-if 
  3356.        #'(lambda (x)
  3357.            (not (eq (ref-inlinep x) :notinline)))
  3358.        fun old))
  3359.     ;;
  3360.     ;; This gets block-compiled functions that aren't entry points (and
  3361.     ;; hence have no XEP).
  3362.     (note-name-defined name :function)
  3363.     ;;
  3364.     ;; If not in a null environment, prevent any backward references to
  3365.     ;; this function from other top-level forms.
  3366.     (unless null-fenv-p (remhash name *free-functions*)))
  3367.       ;;
  3368.       ;; Check for consistency with previous declaration or definition, and
  3369.       ;; assert argument/result types if appropriate.  This this assertion is
  3370.       ;; suppressed by the EXPLICIT-CHECK attribute, which is specified on
  3371.       ;; functions that check their argument types as a consequence of type
  3372.       ;; dispatching.  This avoids redundant checks such as NUMBERP on the args
  3373.       ;; to +, etc.
  3374.       (when (function-type-p save-type)
  3375.     (let ((for-real (eq where-from :declared)))
  3376.       (assert-definition-type
  3377.        fun save-type
  3378.        :error-function #'compiler-warning
  3379.        :warning-function (cond (function-info #'compiler-warning)
  3380.                    (for-real #'compiler-note)
  3381.                    (t nil))
  3382.        :really-assert
  3383.        (and for-real
  3384.         (not (and function-info
  3385.               (ir1-attributep
  3386.                (function-info-attributes function-info)
  3387.                explicit-check))))
  3388.        :where (if for-real
  3389.               "previous declaration"
  3390.               "previous definition"))))
  3391.  
  3392.       (ir1-convert
  3393.        start cont
  3394.        (if (and *block-compile* *entry-points*
  3395.         (not (member name *entry-points* :test #'equal)))
  3396.        `',name
  3397.        `(%%defun ',name ,fun ,doc
  3398.              ,@(when expansion `(',expansion)))))
  3399.       (when *compile-print*
  3400.     (compiler-mumble "Converted ~S.~%" name)))))
  3401.  
  3402.  
  3403. ;;; Update the global environment to correspond to the new definition.  We only
  3404. ;;; record a constant-value when the value is obviously constant.  We can have
  3405. ;;; an optimizer for %%Defconstant that notices when the value becomes constant
  3406. ;;; and substitutes for the Global-Var structure.
  3407. ;;;
  3408. (def-ir1-translator %defconstant ((name value doc) start cont
  3409.                   :kind :function)
  3410.   (let ((name (eval name))
  3411.     (newval (eval value)))
  3412.     (unless (symbolp name)
  3413.       (compiler-error "Constant name is not a symbol: ~S." name))
  3414.     (when (eq name t)
  3415.       (compiler-error "Can't change T."))
  3416.     (when (eq name nil)
  3417.       (compiler-error "Nilhil ex nilhil (Can't change NIL)."))
  3418.     (when (keywordp name)
  3419.       (compiler-error "Can't change the value of keywords."))
  3420.  
  3421.     (let ((kind (info variable kind name)))
  3422.       (case kind
  3423.     (:constant
  3424.      (unless (equalp newval (info variable constant-value name))
  3425.        (compiler-warning "Redefining constant ~S as:~%  ~S"
  3426.                  name newval)))
  3427.     (:global)
  3428.     (t
  3429.      (compiler-warning "Redefining ~(~A~) ~S to be a constant."
  3430.                kind name))))
  3431.  
  3432.     (setf (info variable kind name) :constant)
  3433.     (setf (info variable where-from name) :defined)
  3434.     (setf (info variable constant-value name) newval)
  3435.     (remhash name *free-variables*))
  3436.  
  3437.   (ir1-convert start cont `(%%defconstant ,name ,value ,doc)))
  3438.